Session Transitive_Models

Theory Nat_Miscellanea

section‹Auxiliary results on arithmetic›

theory Nat_Miscellanea
  imports
    Delta_System_Lemma.ZF_Library
begin

(* no_notation add (infixl ‹#+› 65)
no_notation diff (infixl ‹#-› 65) *)
notation add (infixl ‹+ω› 65)
notation diff (infixl ‹-ω› 65)

text‹Most of these results will get used at some point for the
calculation of arities.›

lemmas nat_succI =  Ord_succ_mem_iff [THEN iffD2,OF nat_into_Ord]

lemma nat_succD : "m ∈ nat ⟹  succ(n) ∈ succ(m) ⟹ n ∈ m"
  by (drule_tac j="succ(m)" in ltI,auto elim:ltD)

lemmas zero_in_succ = ltD [OF nat_0_le]

lemma in_n_in_nat :  "m ∈ nat ⟹ n ∈ m ⟹ n ∈ nat"
  by(drule ltI[of "n"],auto simp add: lt_nat_in_nat)

lemma ltI_neg : "x ∈ nat ⟹ j ≤ x ⟹ j ≠ x ⟹ j < x"
  by (simp add: le_iff)

lemma succ_pred_eq  :  "m ∈ nat ⟹ m ≠ 0  ⟹ succ(pred(m)) = m"
  by (auto elim: natE)

lemma succ_ltI : "succ(j) < n ⟹ j < n"
  by (simp add: succ_leE[OF leI])

lemmas succ_leD = succ_leE[OF leI]

lemma succpred_leI : "n ∈ nat ⟹  n ≤ succ(pred(n))"
  by (auto elim: natE)

lemma succpred_n0 : "succ(n) ∈ p ⟹ p≠0"
  by (auto)

lemmas natEin = natE [OF lt_nat_in_nat]

lemmas Un_least_lt_iffn =  Un_least_lt_iff [OF nat_into_Ord nat_into_Ord]

lemma pred_type : "m ∈ nat ⟹ n ≤ m ⟹ n∈nat"
  by (rule leE,auto simp:in_n_in_nat ltD)

lemma pred_le : "m ∈ nat ⟹ n ≤ succ(m) ⟹ pred(n) ≤ m"
  by(rule_tac n="n" in natE,auto simp add:pred_type[of "succ(m)"])

lemma pred_le2 : "n∈ nat ⟹ m ∈ nat ⟹ pred(n) ≤ m ⟹ n ≤ succ(m)"
  by(subgoal_tac "n∈nat",rule_tac n="n" in natE,auto)

lemma Un_leD1 : "Ord(i)⟹ Ord(j)⟹ Ord(k)⟹  i ∪ j ≤ k ⟹ i ≤ k"
  by (rule Un_least_lt_iff[THEN iffD1[THEN conjunct1]],simp_all)

lemma Un_leD2 : "Ord(i)⟹ Ord(j)⟹ Ord(k)⟹  i ∪ j ≤k ⟹ j ≤ k"
  by (rule Un_least_lt_iff[THEN iffD1[THEN conjunct2]],simp_all)

lemma gt1 : "n ∈ nat ⟹ i ∈ n ⟹ i ≠ 0 ⟹ i ≠ 1 ⟹ 1<i"
  by(rule_tac n="i" in natE,erule in_n_in_nat,auto intro: Ord_0_lt)

lemma pred_mono : "m ∈ nat ⟹ n ≤ m ⟹ pred(n) ≤ pred(m)"
  by(rule_tac n="n" in natE,auto simp add:le_in_nat,erule_tac n="m" in natE,auto)

lemma succ_mono : "m ∈ nat ⟹ n ≤ m ⟹ succ(n) ≤ succ(m)"
  by auto

lemma union_abs1 :
  "⟦ i ≤ j ⟧ ⟹ i ∪ j = j"
  by (rule Un_absorb1,erule le_imp_subset)

lemma union_abs2 :
  "⟦ i ≤ j ⟧ ⟹ j ∪ i = j"
  by (rule Un_absorb2,erule le_imp_subset)

lemma ord_un_max : "Ord(i) ⟹ Ord(j) ⟹ i ∪ j = max(i,j)"
  using max_def union_abs1 not_lt_iff_le leI union_abs2
  by auto

lemma ord_max_ty : "Ord(i) ⟹Ord(j) ⟹ Ord(max(i,j))"
  unfolding max_def by simp

lemmas ord_simp_union = ord_un_max ord_max_ty max_def

lemma le_succ : "x∈nat ⟹ x≤succ(x)" by simp

lemma le_pred : "x∈nat ⟹ pred(x)≤x"
  using pred_le[OF _ le_succ] pred_succ_eq
  by simp

lemma not_le_anti_sym : "x∈nat ⟹ y ∈ nat ⟹ ¬ x≤y ⟹ ¬y≤x ⟹ y=x"
  using Ord_linear not_le_iff_lt ltD lt_trans
  by auto

lemma Un_le_compat : "o ≤ p ⟹ q ≤ r ⟹ Ord(o) ⟹ Ord(p) ⟹ Ord(q) ⟹ Ord(r) ⟹ o ∪ q ≤ p ∪ r"
  using le_trans[of q r "p∪r",OF _ Un_upper2_le] le_trans[of o p "p∪r",OF _ Un_upper1_le]
    ord_simp_union
  by auto

lemma Un_le : "p ≤ r ⟹ q ≤ r ⟹
               Ord(p) ⟹ Ord(q) ⟹ Ord(r) ⟹
                p ∪ q ≤ r"
  using ord_simp_union by auto

lemma Un_leI3 : "o ≤ r ⟹ p ≤ r ⟹ q ≤ r ⟹
                Ord(o) ⟹ Ord(p) ⟹ Ord(q) ⟹ Ord(r) ⟹
                o ∪ p ∪ q ≤ r"
  using ord_simp_union by auto

lemma diff_mono :
  assumes "m ∈ nat" "n∈nat" "p ∈ nat" "m < n" "p≤m"
  shows "m#-p < n#-p"
proof -
  from assms
  have "m#-p ∈ nat" "m#-p +ωp = m"
    using add_diff_inverse2 by simp_all
  with assms
  show ?thesis
    using less_diff_conv[of n p "m #- p",THEN iffD2] by simp
qed

lemma pred_Un:
  "x ∈ nat ⟹ y ∈ nat ⟹ pred(succ(x) ∪ y) = x ∪ pred(y)"
  "x ∈ nat ⟹ y ∈ nat ⟹ pred(x ∪ succ(y)) = pred(x) ∪ y"
  using pred_Un_distrib pred_succ_eq by simp_all

lemma le_natI : "j ≤ n ⟹ n ∈ nat ⟹ j∈nat"
  by(drule ltD,rule in_n_in_nat,rule nat_succ_iff[THEN iffD2,of n],simp_all)

lemma le_natE : "n∈nat ⟹ j < n ⟹  j∈n"
  by(rule ltE[of j n],simp+)

lemma leD : assumes "n∈nat" "j ≤ n"
  shows "j < n | j = n"
  using leE[OF ‹j≤n›,of "j<n | j = n"] by auto

lemma pred_nat_eq :
  assumes "n∈nat"
  shows "pred(n) = ⋃ n"
  using assms
proof(induct)
  case 0
  then show ?case by simp
next
  case (succ x)
  then show ?case using pred_succ_eq Ord_Union_succ_eq
    by simp
qed

subsection‹Some results in ordinal arithmetic›
text‹The following results are auxiliary to the proof of
wellfoundedness of the relation term‹frecR››

lemma max_cong :
  assumes "x ≤ y" "Ord(y)" "Ord(z)"
  shows "max(x,y) ≤ max(y,z)"
proof (cases "y ≤ z")
  case True
  then show ?thesis
    unfolding max_def using assms by simp
next
  case False
  then have "z ≤ y"  using assms not_le_iff_lt leI by simp
  then show ?thesis
    unfolding max_def using assms by simp
qed

lemma max_commutes :
  assumes "Ord(x)" "Ord(y)"
  shows "max(x,y) = max(y,x)"
  using assms Un_commute ord_simp_union(1) ord_simp_union(1)[symmetric] by auto

lemma max_cong2 :
  assumes "x ≤ y" "Ord(y)" "Ord(z)" "Ord(x)"
  shows "max(x,z) ≤ max(y,z)"
proof -
  from assms
  have " x ∪ z ≤ y ∪ z"
    using lt_Ord Ord_Un Un_mono[OF  le_imp_subset[OF ‹x≤y›]]  subset_imp_le by auto
  then show ?thesis
    using  ord_simp_union ‹Ord(x)› ‹Ord(z)› ‹Ord(y)› by simp
qed

lemma max_D1 :
  assumes "x = y" "w < z"  "Ord(x)"  "Ord(w)" "Ord(z)" "max(x,w) = max(y,z)"
  shows "z≤y"
proof -
  from assms
  have "w <  x ∪ w" using Un_upper2_lt[OF ‹w<z›] assms ord_simp_union by simp
  then
  have "w < x" using assms lt_Un_iff[of x w w] lt_not_refl by auto
  then
  have "y = y ∪ z" using assms max_commutes ord_simp_union assms leI by simp
  then
  show ?thesis using Un_leD2 assms by simp
qed

lemma max_D2 :
  assumes "w = y ∨ w = z" "x < y"  "Ord(x)"  "Ord(w)" "Ord(y)" "Ord(z)" "max(x,w) = max(y,z)"
  shows "x<w"
proof -
  from assms
  have "x < z ∪ y" using Un_upper2_lt[OF ‹x<y›] by simp
  then
  consider (a) "x < y" | (b) "x < w"
    using assms ord_simp_union by simp
  then show ?thesis proof (cases)
    case a
    consider (c) "w = y" | (d) "w = z"
      using assms by auto
    then show ?thesis proof (cases)
      case c
      with a show ?thesis by simp
    next
      case d
      with a
      show ?thesis
      proof (cases "y <w")
        case True
        then show ?thesis using lt_trans[OF ‹x<y›] by simp
      next
        case False
        then
        have "w ≤ y"
          using not_lt_iff_le[OF assms(5) assms(4)] by simp
        with ‹w=z›
        have "max(z,y) = y"  unfolding max_def using assms by simp
        with assms
        have "... = x ∪ w" using ord_simp_union max_commutes  by simp
        then show ?thesis using le_Un_iff assms by blast
      qed
    qed
  next
    case b
    then show ?thesis .
  qed
qed

lemma oadd_lt_mono2 :
  assumes  "Ord(n)" "Ord(α)" "Ord(β)" "α < β" "x < n" "y < n" "0 <n"
  shows "n ** α + x < n **β + y"
proof -
  consider (0) "β=0" | (s) γ where  "Ord(γ)" "β = succ(γ)" | (l) "Limit(β)"
    using Ord_cases[OF ‹Ord(β)›,of ?thesis] by force
  then show ?thesis
  proof cases
    case 0
    then show ?thesis using ‹α<β› by auto
  next
    case s
    then
    have "α≤γ" using ‹α<β› using leI by auto
    then
    have "n ** α ≤ n ** γ" using omult_le_mono[OF _ ‹α≤γ›] ‹Ord(n)› by simp
    then
    have "n ** α + x < n ** γ + n" using oadd_lt_mono[OF _ ‹x<n›] by simp
    also
    have "... = n ** β" using ‹β=succ(_)› omult_succ ‹Ord(β)› ‹Ord(n)› by simp
    finally
    have "n ** α + x < n ** β" by auto
    then
    show ?thesis using oadd_le_self ‹Ord(β)› lt_trans2 ‹Ord(n)› by auto
  next
    case l
    have "Ord(x)" using ‹x<n› lt_Ord by simp
    with l
    have "succ(α) < β" using Limit_has_succ ‹α<β› by simp
    have "n ** α + x < n ** α + n"
      using oadd_lt_mono[OF le_refl[OF Ord_omult[OF _ ‹Ord(α)›]] ‹x<n›] ‹Ord(n)› by simp
    also
    have "... = n ** succ(α)" using omult_succ ‹Ord(α)› ‹Ord(n)› by simp
    finally
    have "n ** α + x < n ** succ(α)" by simp
    with ‹succ(α) < β›
    have "n ** α + x < n ** β" using lt_trans omult_lt_mono ‹Ord(n)› ‹0<n›  by auto
    then show ?thesis using oadd_le_self ‹Ord(β)› lt_trans2 ‹Ord(n)› by auto
  qed
qed
end
body>

Theory ZF_Miscellanea

section‹Various results missing from ZF.›

theory ZF_Miscellanea
  imports
    ZF
    Nat_Miscellanea
begin

lemma function_subset:
  "function(f) ⟹ g⊆f ⟹ function(g)"
  unfolding function_def subset_def by auto

lemma converse_refl : "refl(A,r) ⟹ refl(A,converse(r))"
  unfolding refl_def by simp

lemma Ord_lt_subset : "Ord(b) ⟹ a<b ⟹ a⊆b"
  by(intro subsetI,frule ltD,rule_tac Ord_trans,simp_all)

lemma funcI : "f ∈ A → B ⟹ a ∈ A ⟹ b= f ` a ⟹ ⟨a, b⟩ ∈ f"
  by(simp_all add: apply_Pair)

lemma vimage_fun_sing:
  assumes "f∈A→B" "b∈B"
  shows "{a∈A . f`a=b} = f-``{b}"
  using assms vimage_singleton_iff function_apply_equality Pi_iff funcI by auto

lemma image_fun_subset: "S∈A→B ⟹ C⊆A⟹ {S ` x . x∈ C} = S``C"
  using image_function[symmetric,of S C] domain_of_fun Pi_iff by auto

lemma subset_Diff_Un: "X ⊆ A ⟹ A = (A - X) ∪ X " by auto

lemma Diff_bij:
  assumes "∀A∈F. X ⊆ A" shows "(λA∈F. A-X) ∈ bij(F, {A-X. A∈F})"
  using assms unfolding bij_def inj_def surj_def
  by (auto intro:lam_type, subst subset_Diff_Un[of X]) auto

lemma function_space_nonempty:
  assumes "b∈B"
  shows "(λx∈A. b) : A → B"
  using assms lam_type by force

lemma vimage_lam: "(λx∈A. f(x)) -`` B = { x∈A . f(x) ∈ B }"
  using lam_funtype[of A f, THEN [2] domain_type]
    lam_funtype[of A f, THEN [2] apply_equality] lamI[of _ A f]
  by auto blast

lemma range_fun_subset_codomain:
  assumes "h:B → C"
  shows "range(h) ⊆ C"
  unfolding range_def domain_def converse_def using range_type[OF _ assms]  by auto

lemma Pi_rangeD:
  assumes "f∈Pi(A,B)" "b ∈ range(f)"
  shows "∃a∈A. f`a = b"
  using assms apply_equality[OF _ assms(1), of _ b]
    domain_type[OF _ assms(1)] by auto

lemma Pi_range_eq: "f ∈ Pi(A,B) ⟹ range(f) = {f ` x . x ∈ A}"
  using Pi_rangeD[of f A B] apply_rangeI[of f A B]
  by blast

lemma Pi_vimage_subset : "f ∈ Pi(A,B) ⟹ f-``C ⊆ A"
  unfolding Pi_def by auto

definition
  minimum :: "i ⇒ i ⇒ i" where
  "minimum(r,B) ≡ THE b. first(b,B,r)"

lemma minimum_in: "⟦ well_ord(A,r); B⊆A; B≠0 ⟧ ⟹ minimum(r,B) ∈ B"
  using the_first_in unfolding minimum_def by simp

lemma well_ord_surj_imp_inj_inverse:
  assumes "well_ord(A,r)" "h ∈ surj(A,B)"
  shows "(λb∈B. minimum(r, {a∈A. h`a=b})) ∈ inj(B,A)"
proof -
  let ?f="λb∈B. minimum(r, {a∈A. h`a=b})"
  have "minimum(r, {a ∈ A . h ` a = b}) ∈ {a∈A. h`a=b}" if "b∈B" for b
  proof -
    from ‹h ∈ surj(A,B)› that
    have "{a∈A. h`a=b} ≠ 0"
      unfolding surj_def by blast
    with ‹well_ord(A,r)›
    show "minimum(r,{a∈A. h`a=b}) ∈ {a∈A. h`a=b}"
      using minimum_in by blast
  qed
  moreover from this
  have "?f : B → A"
    using lam_type[of B _ "λ_.A"] by simp
  moreover
  have "?f ` w = ?f ` x ⟹ w = x" if "w∈B" "x∈B" for w x
  proof -
    from calculation that
    have "w = h ` minimum(r,{a∈A. h`a=w})"
      "x = h ` minimum(r,{a∈A. h`a=x})"
      by simp_all
    moreover
    assume "?f ` w = ?f ` x"
    moreover from this and that
    have "minimum(r, {a ∈ A . h ` a = w}) = minimum(r, {a ∈ A . h ` a = x})"
      unfolding minimum_def by simp_all
    moreover from calculation(1,2,4)
    show "w=x" by simp
  qed
  ultimately
  show ?thesis
    unfolding inj_def by blast
qed

lemma well_ord_surj_imp_lepoll:
  assumes "well_ord(A,r)" "h ∈ surj(A,B)"
  shows "B≲A"
  unfolding lepoll_def using well_ord_surj_imp_inj_inverse[OF assms]
  by blast

― ‹New result›
lemma surj_imp_well_ord:
  assumes "well_ord(A,r)" "h ∈ surj(A,B)"
  shows "∃s. well_ord(B,s)"
  using assms lepoll_well_ord[OF well_ord_surj_imp_lepoll]
  by force

lemma Pow_sing : "Pow({a}) = {0,{a}}"
proof(intro equalityI,simp_all)
  have "z ∈ {0,{a}}" if "z ⊆ {a}" for z
    using that by auto
  then
  show " Pow({a}) ⊆ {0, {a}}" by auto
qed

lemma Pow_cons:
  shows "Pow(cons(a,A)) = Pow(A) ∪ {{a} ∪ X . X: Pow(A)}"
  using Un_Pow_subset Pow_sing
proof(intro equalityI,auto simp add:Un_Pow_subset)
  {
    fix C D
    assume "⋀ B . B∈Pow(A) ⟹ C ≠ {a} ∪ B" "C ⊆ {a} ∪ A" "D ∈ C"
    moreover from this
    have "∀x∈C . x=a ∨ x∈A" by auto
    moreover from calculation
    consider (a) "D=a" | (b) "D∈A" by auto
    from this
    have "D∈A"
    proof(cases)
      case a
      with calculation show ?thesis by auto
    next
      case b
      then show ?thesis by simp
    qed
  }
  then show "⋀x xa. (∀xa∈Pow(A). x ≠ {a} ∪ xa) ⟹ x ⊆ cons(a, A) ⟹ xa ∈ x ⟹ xa ∈ A"
    by auto
qed

lemma app_nm :
  assumes "n∈nat" "m∈nat" "f∈n→m" "x ∈ nat"
  shows "f`x ∈ nat"
proof(cases "x∈n")
  case True
  then show ?thesis using assms in_n_in_nat apply_type by simp
next
  case False
  then show ?thesis using assms apply_0 domain_of_fun by simp
qed

lemma Upair_eq_cons: "Upair(a,b) = {a,b}"
  unfolding cons_def by auto

lemma converse_apply_eq : "converse(f) ` x = ⋃(f -`` {x})"
  unfolding apply_def vimage_def by simp

lemmas app_fun = apply_iff[THEN iffD1]

lemma Finite_imp_lesspoll_nat:
  assumes "Finite(A)"
  shows "A ≺ nat"
  using assms subset_imp_lepoll[OF naturals_subset_nat] eq_lepoll_trans
    n_lesspoll_nat eq_lesspoll_trans
  unfolding Finite_def lesspoll_def by auto

end

Theory Renaming

section‹Renaming of variables in internalized formulas›

theory Renaming
  imports
    ZF_Miscellanea
    "ZF-Constructible.Formula"
begin

subsection‹Renaming of free variables›

definition
  union_fun :: "[i,i,i,i] ⇒ i" where
  "union_fun(f,g,m,p) ≡ λj ∈ m ∪ p  . if j∈m then f`j else g`j"

lemma union_fun_type:
  assumes "f ∈ m → n"
    "g ∈ p → q"
  shows "union_fun(f,g,m,p) ∈ m ∪ p → n ∪ q"
proof -
  let ?h="union_fun(f,g,m,p)"
  have
    D: "?h`x ∈ n ∪ q" if "x ∈ m ∪ p" for x
  proof (cases "x ∈ m")
    case True
    then have
      "x ∈ m ∪ p" by simp
    with ‹x∈m›
    have "?h`x = f`x"
      unfolding union_fun_def  beta by simp
    with ‹f ∈ m → n› ‹x∈m›
    have "?h`x ∈ n" by simp
    then show ?thesis ..
  next
    case False
    with ‹x ∈ m ∪ p›
    have "x ∈ p"
      by auto
    with ‹x∉m›
    have "?h`x = g`x"
      unfolding union_fun_def using beta by simp
    with ‹g ∈ p → q› ‹x∈p›
    have "?h`x ∈ q" by simp
    then show ?thesis ..
  qed
  have A:"function(?h)" unfolding union_fun_def using function_lam by simp
  have " x∈ (m ∪ p) × (n ∪ q)" if "x∈ ?h" for x
    using that lamE[of x "m ∪ p" _ "x ∈ (m ∪ p) × (n ∪ q)"] D unfolding union_fun_def
    by auto
  then have B:"?h ⊆ (m ∪ p) × (n ∪ q)" ..
  have "m ∪ p ⊆ domain(?h)"
    unfolding union_fun_def using domain_lam by simp
  with A B
  show ?thesis using  Pi_iff [THEN iffD2] by simp
qed

lemma union_fun_action :
  assumes
    "env ∈ list(M)"
    "env' ∈ list(M)"
    "length(env) = m ∪ p"
    "∀ i . i ∈ m ⟶  nth(f`i,env') = nth(i,env)"
    "∀ j . j ∈ p ⟶ nth(g`j,env') = nth(j,env)"
  shows "∀ i . i ∈ m ∪ p ⟶
          nth(i,env) = nth(union_fun(f,g,m,p)`i,env')"
proof -
  let ?h = "union_fun(f,g,m,p)"
  have "nth(x, env) = nth(?h`x,env')" if "x ∈ m ∪ p" for x
    using that
  proof (cases "x∈m")
    case True
    with ‹x∈m›
    have "?h`x = f`x"
      unfolding union_fun_def  beta by simp
    with assms ‹x∈m›
    have "nth(x,env) = nth(?h`x,env')" by simp
    then show ?thesis .
  next
    case False
    with ‹x ∈ m ∪ p›
    have
      "x ∈ p" "x∉m"  by auto
    then
    have "?h`x = g`x"
      unfolding union_fun_def beta by simp
    with assms ‹x∈p›
    have "nth(x,env) = nth(?h`x,env')" by simp
    then show ?thesis .
  qed
  then show ?thesis by simp
qed


lemma id_fn_type :
  assumes "n ∈ nat"
  shows "id(n) ∈ n → n"
  unfolding id_def using ‹n∈nat› by simp

lemma id_fn_action:
  assumes "n ∈ nat" "env∈list(M)"
  shows "⋀ j . j < n ⟹ nth(j,env) = nth(id(n)`j,env)"
proof -
  show "nth(j,env) = nth(id(n)`j,env)" if "j < n" for j using that ‹n∈nat› ltD by simp
qed


definition
  rsum :: "[i,i,i,i,i] ⇒ i" where
  "rsum(f,g,m,n,p) ≡ λj ∈ m+ωp  . if j<m then f`j else (g`(j#-m))+ωn"

lemma sum_inl:
  assumes "m ∈ nat" "n∈nat"
    "f ∈ m→n" "x ∈ m"
  shows "rsum(f,g,m,n,p)`x = f`x"
proof -
  from ‹m∈nat›
  have "m≤m+ωp"
    using add_le_self[of m] by simp
  with assms
  have "x∈m+ωp"
    using ltI[of x m] lt_trans2[of x m "m+ωp"] ltD by simp
  from assms
  have "x<m"
    using ltI by simp
  with ‹x∈m+ωp›
  show ?thesis unfolding rsum_def by simp
qed

lemma sum_inr:
  assumes "m ∈ nat" "n∈nat" "p∈nat"
    "g∈p→q" "m ≤ x" "x < m+ωp"
  shows "rsum(f,g,m,n,p)`x = g`(x#-m)+ωn"
proof -
  from assms
  have "x∈nat"
    using in_n_in_nat[of "m+ωp"] ltD
    by simp
  with assms
  have "¬ x<m"
    using not_lt_iff_le[THEN iffD2] by simp
  from assms
  have "x∈m+ωp"
    using ltD by simp
  with ‹¬ x<m›
  show ?thesis unfolding rsum_def by simp
qed


lemma sum_action :
  assumes "m ∈ nat" "n∈nat" "p∈nat" "q∈nat"
    "f ∈ m→n" "g∈p→q"
    "env ∈ list(M)"
    "env' ∈ list(M)"
    "env1 ∈ list(M)"
    "env2 ∈ list(M)"
    "length(env) = m"
    "length(env1) = p"
    "length(env') = n"
    "⋀ i . i < m ⟹ nth(i,env) = nth(f`i,env')"
    "⋀ j. j < p ⟹ nth(j,env1) = nth(g`j,env2)"
  shows "∀ i . i < m+ωp ⟶
          nth(i,env@env1) = nth(rsum(f,g,m,n,p)`i,env'@env2)"
proof -
  let ?h = "rsum(f,g,m,n,p)"
  from ‹m∈nat› ‹n∈nat› ‹q∈nat›
  have "m≤m+ωp" "n≤n+ωq" "q≤n+ωq"
    using add_le_self[of m]  add_le_self2[of n q] by simp_all
  from ‹p∈nat›
  have "p = (m+ωp)#-m" using diff_add_inverse2 by simp
  have "nth(x, env @ env1) = nth(?h`x,env'@env2)" if "x<m+ωp" for x
  proof (cases "x<m")
    case True
    then
    have 2: "?h`x= f`x" "x∈m" "f`x ∈ n" "x∈nat"
      using assms sum_inl ltD apply_type[of f m _ x] in_n_in_nat by simp_all
    with ‹x<m› assms
    have "f`x < n" "f`x<length(env')"  "f`x∈nat"
      using ltI in_n_in_nat by simp_all
    with 2 ‹x<m› assms
    have "nth(x,env@env1) = nth(x,env)"
      using nth_append[OF ‹env∈list(M)›] ‹x∈nat› by simp
    also
    have
      "... = nth(f`x,env')"
      using 2 ‹x<m› assms by simp
    also
    have "... = nth(f`x,env'@env2)"
      using nth_append[OF ‹env'∈list(M)›] ‹f`x<length(env')› ‹f`x ∈nat› by simp
    also
    have "... = nth(?h`x,env'@env2)"
      using 2 by simp
    finally
    have "nth(x, env @ env1) = nth(?h`x,env'@env2)" .
    then show ?thesis .
  next
    case False
    have "x∈nat"
      using that in_n_in_nat[of "m+ωp" x] ltD ‹p∈nat› ‹m∈nat› by simp
    with ‹length(env) = m›
    have "m≤x" "length(env) ≤ x"
      using not_lt_iff_le ‹m∈nat› ‹¬x<m› by simp_all
    with ‹¬x<m› ‹length(env) = m›
    have 2 : "?h`x= g`(x#-m)+ωn"  "¬ x <length(env)"
      unfolding rsum_def
      using  sum_inr that beta ltD by simp_all
    from assms ‹x∈nat› ‹p=m+ωp#-m›
    have "x#-m < p"
      using diff_mono[OF _ _ _ ‹x<m+ωp› ‹m≤x›] by simp
    then have "x#-m∈p" using ltD by simp
    with ‹g∈p→q›
    have "g`(x#-m) ∈ q"  by simp
    with ‹q∈nat› ‹length(env') = n›
    have "g`(x#-m) < q" "g`(x#-m)∈nat" using ltI in_n_in_nat by simp_all
    with ‹q∈nat› ‹n∈nat›
    have "(g`(x#-m))+ωn <n+ωq" "n ≤ g`(x#-m)+ωn" "¬ g`(x#-m)+ωn < length(env')"
      using add_lt_mono1[of "g`(x#-m)" _ n,OF _ ‹q∈nat›]
        add_le_self2[of n] ‹length(env') = n›
      by simp_all
    from assms ‹¬ x < length(env)› ‹length(env) = m›
    have "nth(x,env @ env1) = nth(x#-m,env1)"
      using nth_append[OF ‹env∈list(M)› ‹x∈nat›] by simp
    also
    have "... = nth(g`(x#-m),env2)"
      using assms ‹x#-m < p› by simp
    also
    have "... = nth((g`(x#-m)+ωn)#-length(env'),env2)"
      using  ‹length(env') = n›
        diff_add_inverse2 ‹g`(x#-m)∈nat›
      by simp
    also
    have "... = nth((g`(x#-m)+ωn),env'@env2)"
      using  nth_append[OF ‹env'∈list(M)›] ‹n∈nat› ‹¬ g`(x#-m)+ωn < length(env')›
      by simp
    also
    have "... = nth(?h`x,env'@env2)"
      using 2 by simp
    finally
    have "nth(x, env @ env1) = nth(?h`x,env'@env2)" .
    then show ?thesis .
  qed
  then show ?thesis by simp
qed

lemma sum_type  :
  assumes "m ∈ nat" "n∈nat" "p∈nat" "q∈nat"
    "f ∈ m→n" "g∈p→q"
  shows "rsum(f,g,m,n,p) ∈ (m+ωp) → (n+ωq)"
proof -
  let ?h = "rsum(f,g,m,n,p)"
  from ‹m∈nat› ‹n∈nat› ‹q∈nat›
  have "m≤m+ωp" "n≤n+ωq" "q≤n+ωq"
    using add_le_self[of m]  add_le_self2[of n q] by simp_all
  from ‹p∈nat›
  have "p = (m+ωp)#-m" using diff_add_inverse2 by simp
  {fix x
    assume 1: "x∈m+ωp" "x<m"
    with 1 have "?h`x= f`x" "x∈m"
      using assms sum_inl ltD by simp_all
    with ‹f∈m→n›
    have "?h`x ∈ n" by simp
    with ‹n∈nat› have "?h`x < n" using ltI by simp
    with ‹n≤n+ωq›
    have "?h`x < n+ωq" using lt_trans2 by simp
    then
    have "?h`x ∈ n+ωq"  using ltD by simp
  }
  then have 1:"?h`x ∈ n+ωq" if "x∈m+ωp" "x<m" for x using that .
  {fix x
    assume 1: "x∈m+ωp" "m≤x"
    then have "x<m+ωp" "x∈nat" using ltI in_n_in_nat[of "m+ωp"] ltD by simp_all
    with 1
    have 2 : "?h`x= g`(x#-m)+ωn"
      using assms sum_inr ltD by simp_all
    from assms ‹x∈nat› ‹p=m+ωp#-m›
    have "x#-m < p" using diff_mono[OF _ _ _ ‹x<m+ωp› ‹m≤x›] by simp
    then have "x#-m∈p" using ltD by simp
    with ‹g∈p→q›
    have "g`(x#-m) ∈ q"  by simp
    with ‹q∈nat› have "g`(x#-m) < q" using ltI by simp
    with ‹q∈nat›
    have "(g`(x#-m))+ωn <n+ωq" using add_lt_mono1[of "g`(x#-m)" _ n,OF _ ‹q∈nat›] by simp
    with 2
    have "?h`x ∈ n+ωq"  using ltD by simp
  }
  then have 2:"?h`x ∈ n+ωq" if "x∈m+ωp" "m≤x" for x using that .
  have
    D: "?h`x ∈ n+ωq" if "x∈m+ωp" for x
    using that
  proof (cases "x<m")
    case True
    then show ?thesis using 1 that by simp
  next
    case False
    with ‹m∈nat› have "m≤x" using not_lt_iff_le that in_n_in_nat[of "m+ωp"] by simp
    then show ?thesis using 2 that by simp
  qed
  have A:"function(?h)" unfolding rsum_def using function_lam by simp
  have " x∈ (m +ω p) × (n +ω q)" if "x∈ ?h" for x
    using that lamE[of x "m+ωp" _ "x ∈ (m +ω p) × (n +ω q)"] D unfolding rsum_def
    by auto
  then have B:"?h ⊆ (m +ω p) × (n +ω q)" ..
  have "m +ω p ⊆ domain(?h)"
    unfolding rsum_def using domain_lam by simp
  with A B
  show ?thesis using  Pi_iff [THEN iffD2] by simp
qed

lemma sum_type_id :
  assumes
    "f ∈ length(env)→length(env')"
    "env ∈ list(M)"
    "env' ∈ list(M)"
    "env1 ∈ list(M)"
  shows
    "rsum(f,id(length(env1)),length(env),length(env'),length(env1)) ∈
        (length(env)+ωlength(env1)) → (length(env')+ωlength(env1))"
  using assms length_type id_fn_type sum_type
  by simp

lemma sum_type_id_aux2 :
  assumes
    "f ∈ m→n"
    "m ∈ nat" "n ∈ nat"
    "env1 ∈ list(M)"
  shows
    "rsum(f,id(length(env1)),m,n,length(env1)) ∈
        (m+ωlength(env1)) → (n+ωlength(env1))"
  using assms id_fn_type sum_type
  by auto

lemma sum_action_id :
  assumes
    "env ∈ list(M)"
    "env' ∈ list(M)"
    "f ∈ length(env)→length(env')"
    "env1 ∈ list(M)"
    "⋀ i . i < length(env) ⟹ nth(i,env) = nth(f`i,env')"
  shows "⋀ i . i < length(env)+ωlength(env1) ⟹
          nth(i,env@env1) = nth(rsum(f,id(length(env1)),length(env),length(env'),length(env1))`i,env'@env1)"
proof -
  from assms
  have "length(env)∈nat" (is "?m ∈ _") by simp
  from assms have "length(env')∈nat" (is "?n ∈ _") by simp
  from assms have "length(env1)∈nat" (is "?p ∈ _") by simp
  note lenv = id_fn_action[OF ‹?p∈nat› ‹env1∈list(M)›]
  note lenv_ty = id_fn_type[OF ‹?p∈nat›]
  {
    fix i
    assume "i < length(env)+ωlength(env1)"
    have "nth(i,env@env1) = nth(rsum(f,id(length(env1)),?m,?n,?p)`i,env'@env1)"
      using sum_action[OF ‹?m∈nat› ‹?n∈nat› ‹?p∈nat› ‹?p∈nat› ‹f∈?m→?n›
          lenv_ty ‹env∈list(M)› ‹env'∈list(M)›
          ‹env1∈list(M)› ‹env1∈list(M)› _
          _ _  assms(5) lenv
          ] ‹i<?m+ωlength(env1)› by simp
  }
  then show "⋀ i . i < ?m+ωlength(env1) ⟹
          nth(i,env@env1) = nth(rsum(f,id(?p),?m,?n,?p)`i,env'@env1)" by simp
qed

lemma sum_action_id_aux :
  assumes
    "f ∈ m→n"
    "env ∈ list(M)"
    "env' ∈ list(M)"
    "env1 ∈ list(M)"
    "length(env) = m"
    "length(env') = n"
    "length(env1) = p"
    "⋀ i . i < m ⟹ nth(i,env) = nth(f`i,env')"
  shows "⋀ i . i < m+ωlength(env1) ⟹
          nth(i,env@env1) = nth(rsum(f,id(length(env1)),m,n,length(env1))`i,env'@env1)"
  using assms length_type id_fn_type sum_action_id
  by auto


definition
  sum_id :: "[i,i] ⇒ i" where
  "sum_id(m,f) ≡ rsum(λx∈1.x,f,1,1,m)"

lemma sum_id0 : "m∈nat⟹sum_id(m,f)`0 = 0"
  by(unfold sum_id_def,subst sum_inl,auto)

lemma sum_idS : "p∈nat ⟹ q∈nat ⟹ f∈p→q ⟹ x ∈ p ⟹ sum_id(p,f)`(succ(x)) = succ(f`x)"
  by(subgoal_tac "x∈nat",unfold sum_id_def,subst sum_inr,
      simp_all add:ltI,simp_all add: app_nm in_n_in_nat)

lemma sum_id_tc_aux :
  "p ∈ nat ⟹  q ∈ nat ⟹ f ∈ p → q ⟹ sum_id(p,f) ∈ 1+ωp → 1+ωq"
  by (unfold sum_id_def,rule sum_type,simp_all)

lemma sum_id_tc :
  "n ∈ nat ⟹ m ∈ nat ⟹ f ∈ n → m ⟹ sum_id(n,f) ∈ succ(n) → succ(m)"
  by(rule ssubst[of  "succ(n) → succ(m)" "1+ωn → 1+ωm"],
      simp,rule sum_id_tc_aux,simp_all)

subsection‹Renaming of formulas›

consts   ren :: "i⇒i"
primrec
  "ren(Member(x,y)) =
      (λ n ∈ nat . λ m ∈ nat. λf ∈ n → m. Member (f`x, f`y))"

"ren(Equal(x,y)) =
      (λ n ∈ nat . λ m ∈ nat. λf ∈ n → m. Equal (f`x, f`y))"

"ren(Nand(p,q)) =
      (λ n ∈ nat . λ m ∈ nat. λf ∈ n → m. Nand (ren(p)`n`m`f, ren(q)`n`m`f))"

"ren(Forall(p)) =
      (λ n ∈ nat . λ m ∈ nat. λf ∈ n → m. Forall (ren(p)`succ(n)`succ(m)`sum_id(n,f)))"

lemma arity_meml : "l ∈ nat ⟹ Member(x,y) ∈ formula ⟹ arity(Member(x,y)) ≤ l ⟹ x ∈ l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma arity_memr : "l ∈ nat ⟹ Member(x,y) ∈ formula ⟹ arity(Member(x,y)) ≤ l ⟹ y ∈ l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma arity_eql : "l ∈ nat ⟹ Equal(x,y) ∈ formula ⟹ arity(Equal(x,y)) ≤ l ⟹ x ∈ l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma arity_eqr : "l ∈ nat ⟹ Equal(x,y) ∈ formula ⟹ arity(Equal(x,y)) ≤ l ⟹ y ∈ l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma  nand_ar1 : "p ∈ formula ⟹ q∈formula ⟹arity(p) ≤ arity(Nand(p,q))"
  by (simp,rule Un_upper1_le,simp+)
lemma nand_ar2 : "p ∈ formula ⟹ q∈formula ⟹arity(q) ≤ arity(Nand(p,q))"
  by (simp,rule Un_upper2_le,simp+)

lemma nand_ar1D : "p ∈ formula ⟹ q∈formula ⟹ arity(Nand(p,q)) ≤ n ⟹ arity(p) ≤ n"
  by(auto simp add:  le_trans[OF Un_upper1_le[of "arity(p)" "arity(q)"]])
lemma nand_ar2D : "p ∈ formula ⟹ q∈formula ⟹ arity(Nand(p,q)) ≤ n ⟹ arity(q) ≤ n"
  by(auto simp add:  le_trans[OF Un_upper2_le[of "arity(p)" "arity(q)"]])


lemma ren_tc : "p ∈ formula ⟹
  (⋀ n m f . n ∈ nat ⟹ m ∈ nat ⟹ f ∈ n→m ⟹  ren(p)`n`m`f ∈ formula)"
  by (induct set:formula,auto simp add: app_nm sum_id_tc)


lemma arity_ren :
  fixes "p"
  assumes "p ∈ formula"
  shows "⋀ n m f . n ∈ nat ⟹ m ∈ nat ⟹ f ∈ n→m ⟹ arity(p) ≤ n ⟹ arity(ren(p)`n`m`f)≤m"
  using assms
proof (induct set:formula)
  case (Member x y)
  then have "f`x ∈ m" "f`y ∈ m"
    using Member assms by (simp add: arity_meml apply_funtype,simp add:arity_memr apply_funtype)
  then show ?case using Member by (simp add: Un_least_lt ltI)
next
  case (Equal x y)
  then have "f`x ∈ m" "f`y ∈ m"
    using Equal assms by (simp add: arity_eql apply_funtype,simp add:arity_eqr apply_funtype)
  then show ?case using Equal by (simp add: Un_least_lt ltI)
next
  case (Nand p q)
  then have "arity(p)≤arity(Nand(p,q))"
    "arity(q)≤arity(Nand(p,q))"
    by (subst  nand_ar1,simp,simp,simp,subst nand_ar2,simp+)
  then have "arity(p)≤n"
    and "arity(q)≤n" using Nand
    by (rule_tac j="arity(Nand(p,q))" in le_trans,simp,simp)+
  then have "arity(ren(p)`n`m`f) ≤ m" and  "arity(ren(q)`n`m`f) ≤ m"
    using Nand by auto
  then show ?case using Nand by (simp add:Un_least_lt)
next
  case (Forall p)
  from Forall have "succ(n)∈nat"  "succ(m)∈nat" by auto
  from Forall have 2: "sum_id(n,f) ∈ succ(n)→succ(m)" by (simp add:sum_id_tc)
  from Forall have 3:"arity(p) ≤ succ(n)" by (rule_tac n="arity(p)" in natE,simp+)
  then have "arity(ren(p)`succ(n)`succ(m)`sum_id(n,f))≤succ(m)" using
      Forall ‹succ(n)∈nat› ‹succ(m)∈nat› 2 by force
  then show ?case using Forall 2 3 ren_tc arity_type pred_le by auto
qed

lemma arity_forallE : "p ∈ formula ⟹ m ∈ nat ⟹ arity(Forall(p)) ≤ m ⟹ arity(p) ≤ succ(m)"
  by(rule_tac n="arity(p)" in natE,erule arity_type,simp+)

lemma env_coincidence_sum_id :
  assumes "m ∈ nat" "n ∈ nat"
    "ρ ∈ list(A)" "ρ' ∈ list(A)"
    "f ∈ n → m"
    "⋀ i . i < n ⟹ nth(i,ρ) = nth(f`i,ρ')"
    "a ∈ A" "j ∈ succ(n)"
  shows "nth(j,Cons(a,ρ)) = nth(sum_id(n,f)`j,Cons(a,ρ'))"
proof -
  let ?g="sum_id(n,f)"
  have "succ(n) ∈ nat" using ‹n∈nat› by simp
  then have "j ∈ nat" using ‹j∈succ(n)› in_n_in_nat by blast
  then have "nth(j,Cons(a,ρ)) = nth(?g`j,Cons(a,ρ'))"
  proof (cases rule:natE[OF ‹j∈nat›])
    case 1
    then show ?thesis using assms sum_id0 by simp
  next
    case (2 i)
    with ‹j∈succ(n)› have "succ(i)∈succ(n)" by simp
    with ‹n∈nat› have "i ∈ n" using nat_succD assms by simp
    have "f`i∈m" using ‹f∈n→m› apply_type ‹i∈n› by simp
    then have "f`i ∈ nat" using in_n_in_nat ‹m∈nat› by simp
    have "nth(succ(i),Cons(a,ρ)) = nth(i,ρ)" using ‹i∈nat› by simp
    also have "... = nth(f`i,ρ')" using assms ‹i∈n› ltI by simp
    also have "... = nth(succ(f`i),Cons(a,ρ'))" using ‹f`i∈nat› by simp
    also have "... = nth(?g`succ(i),Cons(a,ρ'))"
      using assms sum_idS[OF ‹n∈nat› ‹m∈nat›  ‹f∈n→m› ‹i ∈ n›] cases by simp
    finally have "nth(succ(i),Cons(a,ρ)) = nth(?g`succ(i),Cons(a,ρ'))" .
    then show ?thesis using ‹j=succ(i)› by simp
  qed
  then show ?thesis .
qed

lemma sats_iff_sats_ren :
  assumes "φ ∈ formula"
  shows  "⟦  n ∈ nat ; m ∈ nat ; ρ ∈ list(M) ; ρ' ∈ list(M) ; f ∈ n → m ;
            arity(φ) ≤ n ;
            ⋀ i . i < n ⟹ nth(i,ρ) = nth(f`i,ρ') ⟧ ⟹
         sats(M,φ,ρ) ⟷ sats(M,ren(φ)`n`m`f,ρ')"
  using ‹φ ∈ formula›
proof(induct φ arbitrary:n m ρ ρ' f)
  case (Member x y)
  have "ren(Member(x,y))`n`m`f = Member(f`x,f`y)" using Member assms arity_type by force
  moreover
  have "x ∈ n" using Member arity_meml by simp
  moreover
  have "y ∈ n" using Member arity_memr by simp
  ultimately
  show ?case using Member ltI by simp
next
  case (Equal x y)
  have "ren(Equal(x,y))`n`m`f = Equal(f`x,f`y)" using Equal assms arity_type by force
  moreover
  have "x ∈ n" using Equal arity_eql by simp
  moreover
  have "y ∈ n" using Equal arity_eqr by simp
  ultimately show ?case using Equal ltI by simp
next
  case (Nand p q)
  have "ren(Nand(p,q))`n`m`f = Nand(ren(p)`n`m`f,ren(q)`n`m`f)" using Nand by simp
  moreover
  have "arity(p) ≤ n" using Nand nand_ar1D by simp
  moreover from this
  have "i ∈ arity(p) ⟹ i ∈ n" for i using subsetD[OF le_imp_subset[OF ‹arity(p) ≤ n›]] by simp
  moreover from this
  have "i ∈ arity(p) ⟹ nth(i,ρ) = nth(f`i,ρ')" for i using Nand ltI by simp
  moreover from this
  have "sats(M,p,ρ) ⟷ sats(M,ren(p)`n`m`f,ρ')" using ‹arity(p)≤n› Nand by simp
  have "arity(q) ≤ n" using Nand nand_ar2D by simp
  moreover from this
  have "i ∈ arity(q) ⟹ i ∈ n" for i using subsetD[OF le_imp_subset[OF ‹arity(q) ≤ n›]] by simp
  moreover from this
  have "i ∈ arity(q) ⟹ nth(i,ρ) = nth(f`i,ρ')" for i using Nand ltI by simp
  moreover from this
  have "sats(M,q,ρ) ⟷ sats(M,ren(q)`n`m`f,ρ')" using assms ‹arity(q)≤n› Nand by simp
  ultimately
  show ?case using Nand by simp
next
  case (Forall p)
  have 0:"ren(Forall(p))`n`m`f = Forall(ren(p)`succ(n)`succ(m)`sum_id(n,f))"
    using Forall by simp
  have 1:"sum_id(n,f) ∈ succ(n) → succ(m)" (is "?g ∈ _") using sum_id_tc Forall by simp
  then have 2: "arity(p) ≤ succ(n)"
    using Forall le_trans[of _ "succ(pred(arity(p)))"] succpred_leI by simp
  have "succ(n)∈nat" "succ(m)∈nat" using Forall by auto
  then have A:"⋀ j .j < succ(n) ⟹ nth(j, Cons(a, ρ)) = nth(?g`j, Cons(a, ρ'))" if "a∈M" for a
    using that env_coincidence_sum_id Forall ltD by force
  have
    "sats(M,p,Cons(a,ρ)) ⟷ sats(M,ren(p)`succ(n)`succ(m)`?g,Cons(a,ρ'))" if "a∈M" for a
  proof -
    have C:"Cons(a,ρ) ∈ list(M)" "Cons(a,ρ')∈list(M)" using Forall that by auto
    have "sats(M,p,Cons(a,ρ)) ⟷ sats(M,ren(p)`succ(n)`succ(m)`?g,Cons(a,ρ'))"
      using Forall(2)[OF ‹succ(n)∈nat› ‹succ(m)∈nat› C(1) C(2) 1 2 A[OF ‹a∈M›]] by simp
    then show ?thesis .
  qed
  then show ?case using Forall 0 1 2 by simp
qed

end
v class="head">

Theory Utils

theory Utils
  imports "ZF-Constructible.Formula"
begin

txt‹This theory encapsulates some ML utilities›
ML_file‹Utils.ml›

end
dy>

File ‹Utils.ml›

signature Utils =
 sig
    val &&& : ('a -> 'b) * ('a -> 'c) -> 'a -> 'b * 'c
    val *** : ('a -> 'b) * ('c -> 'd) -> 'a * 'c -> 'b * 'd
    val @@ : ''a list * ''a list -> ''a list
    val --- : ''a list * ''a list -> ''a list
    val binop : term -> term -> term -> term
    val add_: term -> term -> term
    val add_to_context : string -> Proof.context -> Proof.context
    val app_: term -> term -> term
    val concat_: term -> term -> term
    val dest_apply: term -> term * term
    val dest_abs : string * typ * term -> string * term
    val dest_iff_lhs: term -> term
    val dest_iff_rhs: term -> term
    val dest_iff_tms: term -> term * term
    val dest_lhs_def: term -> term
    val dest_rhs_def: term -> term
    val dest_satisfies_tms: term -> term * term
    val dest_satisfies_frm: term -> term
    val dest_eq_tms: term -> term * term
    val dest_mem_tms: term -> term * term
    val dest_sats_frm: term -> (term * term) * term
    val dest_eq_tms': term -> term * term
    val dest_trueprop: term -> term
    val display : string -> Position.T -> (string * thm list) * Proof.context -> Proof.context
    val eq_: term -> term -> term
    val fix_vars: thm -> string list -> Proof.context -> thm
    val flat : ''a list list -> ''a list
    val formula_: term
    val freeName: term -> string
    val frees : term -> term list
    val length_: term -> term
    val list_: term -> term
    val lt_: term -> term -> term
    val map_option : ('a -> 'b) -> 'a option -> 'b option
    val mem_: term -> term -> term
    val mk_FinSet: term list -> term
    val mk_Pair: term -> term -> term
    val mk_ZFlist: ('a -> term) -> 'a list -> term
    val mk_ZFnat: int -> term
    val nat_: term
    val nth_: term -> term -> term
    val reachable : (''a -> ''a -> bool) -> ''a list -> ''a list -> ''a list
    val subset_: term -> term -> term
    val thm_concl_tm :  Proof.context -> xstring -> (Vars.key * cterm) list  * term * Proof.context
    val to_ML_list: term -> term list
    val tp: term -> term
    val var_i : string -> term
    val zip_with : ('a * 'b -> 'c) -> 'a list -> 'b list -> 'c list
  end

structure Utils : Utils =
struct
(* Smart constructors for ZF-terms *)

fun binop h t u = h $ t $ u

val mk_Pair  = binop @{const Pair}

fun mk_FinSet nil = @{const zero}
  | mk_FinSet (e :: es) = @{const cons} $ e $ mk_FinSet es

fun mk_ZFnat 0 = @{const zero}
  | mk_ZFnat n = @{const succ} $ mk_ZFnat (n-1)

fun mk_ZFlist _ nil = @{const "Nil"}
  | mk_ZFlist f (t :: ts) = @{const "Cons"} $ f t $ mk_ZFlist f ts

fun to_ML_list (@{const Nil}) = nil
  | to_ML_list (@{const Cons} $ t $ ts) = t :: to_ML_list ts
  |   to_ML_list _ = nil

fun freeName (Free (n,_)) = n
  | freeName _ = error "Not a free variable"

val app_ = binop @{const apply}

fun tp x = @{const Trueprop} $ x
fun length_ env = @{const length} $ env
val nth_ = binop @{const nth}
val add_ = binop @{const add}
val mem_ = binop @{const mem}
val subset_ = binop @{const Subset}
val lt_ = binop @{const lt}
val concat_ = binop @{const app}
val eq_ = binop @{const IFOL.eq(i)}

(* Abbreviation for sets *)
fun list_ set = @{const list} $ set
val nat_ = @{const nat}
val formula_ = @{const formula}

(** Destructors of terms **)
fun dest_eq_tms (Const (@{const_name IFOL.eq},_) $ t $ u) = (t, u)
  | dest_eq_tms t = raise TERM ("dest_eq_tms", [t])

fun dest_mem_tms (@{const mem} $ t $ u) = (t, u)
  | dest_mem_tms t = raise TERM ("dest_mem_tms", [t])


fun dest_eq_tms' (Const (@{const_name Pure.eq},_) $ t $ u) = (t, u)
  | dest_eq_tms' t = raise TERM ("dest_eq_tms", [t])

val dest_lhs_def = #1 o dest_eq_tms'
val dest_rhs_def = #2 o dest_eq_tms'

fun dest_apply (@{const apply} $ t $ u) = (t,u)
  | dest_apply t = raise TERM ("dest_applies_op", [t])

fun dest_satisfies_tms (@{const Formula.satisfies} $ A $ f) = (A,f)
  | dest_satisfies_tms t = raise TERM ("dest_satisfies_tms", [t]);

val dest_satisfies_frm = #2 o dest_satisfies_tms

fun dest_sats_frm t = t |> dest_eq_tms |> #1 |> dest_apply |>> dest_satisfies_tms ;

fun dest_trueprop (@{const IFOL.Trueprop} $ t) = t
  | dest_trueprop t = t

fun dest_iff_tms (@{const IFOL.iff} $ t $ u) = (t, u)
  | dest_iff_tms t = raise TERM ("dest_iff_tms", [t])

val dest_iff_lhs = #1 o dest_iff_tms
val dest_iff_rhs = #2 o dest_iff_tms

fun thm_concl_tm ctxt thm_ref =
  let
    val thm = Proof_Context.get_thm ctxt thm_ref
    val thm_vars = rev (Term.add_vars (Thm.full_prop_of thm) [])
    val (((_,inst),thm_tms),ctxt1) = Variable.import true [thm] ctxt
    val vars = map (fn v => (v, the (Vars.lookup inst v))) thm_vars
  in
    (vars, thm_tms |> hd |> Thm.concl_of, ctxt1)
end

fun fix_vars thm vars ctxt = let
  val (_, ctxt1) = Variable.add_fixes vars ctxt
  in singleton (Proof_Context.export ctxt1 ctxt) thm
end

fun display kind pos (thms,thy) =
  let val _ = Proof_Display.print_results true pos thy ((kind,""),[thms])
  in thy
end

(* lists as sets *)

infix 6 @@
fun op @@ (xs, ys) = union (op =) ys xs

fun flat xss = fold (curry op @@) xss []

infix 6 ---
fun op --- (xs, ys) = subtract (op =) ys xs

(* function product *)
infix 6 &&&
fun op &&& (f, g) = fn x => (f x, g x)

infix 6 ***
fun op *** (f, g) = fn (x, y) => (f x, g y)

(* add variable to context *)
fun add_to_context v c = if Variable.is_fixed c v then c else #2 (Variable.add_fixes [v] c)

(* get free variables of a term *)
fun frees t = fold_aterms (fn t => if is_Free t then cons t else I) t []

(* closure of a set wrt a preorder *)
(* the preorder is the reflexive-transitive closure of the given relation p *)
(* u represents the universe, and xs represents the starting points *)
(* [xs]_{p,u} = { v ∈ u . ∃ x ∈ xs . p*(x, v) }*)
fun reachable p u xs =
  let
    val step = map (fn x => filter (p x) (u --- xs)) xs |> flat
    val acc = if null step then [] else reachable p (u --- xs) step
  in
    xs @@ acc
  end

fun zip_with _ [] _ = []
  | zip_with _ _ [] = []
  | zip_with f (x :: xs) (y :: ys) = f (x, y) :: zip_with f xs ys

fun var_i s = Free (s, @{typ "i"})

fun map_option f (SOME a) = SOME (f a)
  | map_option _ NONE = NONE

fun dest_abs (v, ty, t) = (v, Term.subst_bound ((Free (v, ty)), t))

end
ody>

Theory Renaming_Auto

theory Renaming_Auto
  imports
    Renaming
    Utils
keywords
  "rename" :: thy_decl % "ML"
and
  "simple_rename" :: thy_decl % "ML"
and
  "src"
and
  "tgt"
abbrevs
  "simple_rename" = ""

begin

lemmas nat_succI = nat_succ_iff[THEN iffD2]
ML_file‹Renaming_ML.ml›
ML‹
  open Renaming_ML

  fun renaming_def mk_ren name from to ctxt =
    let val to = to |> Syntax.read_term ctxt
        val from = from |> Syntax.read_term ctxt
        val (tc_lemma,action_lemma,fvs,r) = mk_ren from to ctxt
        val (tc_lemma,action_lemma) = (fix_vars tc_lemma fvs ctxt , fix_vars action_lemma fvs ctxt)
        val ren_fun_name = Binding.name (name ^ "_fn")
        val ren_fun_def =  Binding.name (name ^ "_fn_def")
        val ren_thm = Binding.name (name ^ "_thm")
    in
      Local_Theory.note   ((ren_thm, []), [tc_lemma,action_lemma]) ctxt |> snd |>
      Local_Theory.define ((ren_fun_name, NoSyn), ((ren_fun_def, []), r)) |> snd
  end;
›

ML‹
local

  val ren_parser = Parse.position (Parse.string --
      (Parse.$$$ "src" |-- Parse.string --| Parse.$$$ "tgt" -- Parse.string));

  val _ =
   Outer_Syntax.local_theory command_keyword‹rename› "ML setup for synthetic definitions"
     (ren_parser >> (fn ((name,(from,to)),_) => renaming_def sum_rename name from to ))

  val _ =
   Outer_Syntax.local_theory command_keyword‹simple_rename› "ML setup for synthetic definitions"
     (ren_parser >> (fn ((name,(from,to)),_) => renaming_def ren_thm name from to ))

in
end
›
end

File ‹Renaming_ML.ml›

structure Renaming_ML = struct
open Utils

fun sum_ f g m n p = @{const Renaming.rsum} $ f $ g $ m $ n $ p

(*Builds a finite mapping from rho to rho'.*)
fun mk_ren rho rho' ctxt =
  let val rs  = to_ML_list rho
      val rs' = to_ML_list rho'
      val ixs = 0 upto (length rs-1)
      fun err t = "The element " ^ Syntax.string_of_term ctxt t ^ " is missing in the target environment"
      fun mkp i =
          case find_index (fn x => x = nth rs i) rs' of
            ~1 => nth rs i |> err |> error
          |  j => mk_Pair (mk_ZFnat i) (mk_ZFnat j)
  in  map mkp ixs |> mk_FinSet
  end

fun mk_dom_lemma ren rho =
  let val n = rho |> to_ML_list |> length |> mk_ZFnat
  in eq_ n (@{const domain} $ ren) |> tp
end

fun ren_tc_goal fin ren rho rho' =
  let val n = rho |> to_ML_list |> length |> mk_ZFnat
      val m = rho' |> to_ML_list |> length |> mk_ZFnat
      val fun_ty = if fin then @{const_name "FiniteFun"} else @{const_abbrev "function_space"}
      val ty = Const (fun_ty,@{typ "i ⇒ i ⇒ i"}) $ n $ m
  in  mem_ ren ty |> tp
end

fun ren_action_goal ren rho rho' ctxt =
  let val setV = Variable.variant_frees ctxt [] [("A",@{typ i})] |> hd |> Free
      val j = Variable.variant_frees ctxt [] [("j",@{typ i})] |> hd |> Free
      val vs = rho  |> to_ML_list
      val ws = rho' |> to_ML_list |> filter Term.is_Free
      val h1 = subset_ (mk_FinSet vs) setV
      val h2 = lt_ j (length vs |> mk_ZFnat)
      val fvs = [j,setV ] @ ws |> filter Term.is_Free |> map freeName
      val lhs = nth_ j rho
      val rhs = nth_ (app_ ren j)  rho'
      val concl = eq_ lhs rhs
   in (Logic.list_implies([tp h1,tp h2],tp concl),fvs)
  end

  fun sum_tc_goal f m n p =
    let val m_length = m |> to_ML_list |> length |> mk_ZFnat
        val n_length = n |> to_ML_list |> length |> mk_ZFnat
        val p_length = p |> length_
        val id_fun = @{const id} $ p_length
        val sum_fun = sum_ f id_fun m_length n_length p_length
        val dom = add_ m_length p_length
        val codom = add_ n_length p_length
        val fun_ty = @{const_abbrev "function_space"}
        val ty = Const (fun_ty,@{typ "i ⇒ i ⇒ i"}) $ dom $ codom
  in  (sum_fun, mem_ sum_fun ty |> tp)
  end

fun sum_action_goal ren rho rho' ctxt =
  let val setV = Variable.variant_frees ctxt [] [("A",@{typ i})] |> hd |> Free
      val envV = Variable.variant_frees ctxt [] [("env",@{typ i})] |> hd |> Free
      val j = Variable.variant_frees ctxt [] [("j",@{typ i})] |> hd |> Free
      val vs = rho  |> to_ML_list
      val ws = rho' |> to_ML_list |> filter Term.is_Free
      val envL = envV |> length_
      val rhoL = vs |> length |> mk_ZFnat
      val h1 = subset_ (append vs ws |> mk_FinSet) setV
      val h2 = lt_ j (add_ rhoL envL)
      val h3 = mem_ envV (list_ setV)
      val fvs = ([j,setV,envV] @ ws |> filter Term.is_Free) |> map freeName
      val lhs = nth_ j (concat_ rho envV)
      val rhs = nth_ (app_ ren j) (concat_ rho' envV)
      val concl = eq_ lhs rhs
   in (Logic.list_implies([tp h1,tp h2,tp h3],tp concl),fvs)
  end

  (* Tactics *)
  fun fin ctxt =
         REPEAT (resolve_tac ctxt [@{thm nat_succI}] 1)
         THEN   resolve_tac ctxt [@{thm nat_0I}] 1

  fun step ctxt thm =
    asm_full_simp_tac ctxt 1
    THEN asm_full_simp_tac ctxt 1
    THEN EqSubst.eqsubst_tac ctxt [1] [@{thm app_fun} OF [thm]] 1
    THEN simp_tac ctxt 1
    THEN simp_tac ctxt 1

  fun fin_fun_tac ctxt =
    REPEAT (
      resolve_tac ctxt [@{thm consI}] 1
      THEN resolve_tac ctxt [@{thm ltD}] 1
      THEN simp_tac ctxt 1
      THEN resolve_tac ctxt [@{thm ltD}] 1
      THEN simp_tac ctxt 1)
    THEN resolve_tac ctxt [@{thm emptyI}] 1
  THEN REPEAT (simp_tac ctxt 1)

  fun ren_thm e e' ctxt =
   let
    val r = mk_ren e e' ctxt
    val fin_tc_goal = ren_tc_goal true r e e'
    val dom_goal =  mk_dom_lemma r e
    val tc_goal = ren_tc_goal false r e e'
    val (action_goal,fvs) = ren_action_goal r e e' ctxt
    val fin_tc_lemma = Goal.prove ctxt [] [] fin_tc_goal (fn _ => fin_fun_tac ctxt)
    val dom_lemma = Goal.prove ctxt [] [] dom_goal (fn _ => blast_tac ctxt 1)
    val tc_lemma =  Goal.prove ctxt [] [] tc_goal
            (fn _ =>  EqSubst.eqsubst_tac ctxt [1] [dom_lemma] 1
              THEN resolve_tac ctxt [@{thm FiniteFun_is_fun}] 1
              THEN resolve_tac ctxt [fin_tc_lemma] 1)
    val action_lemma = Goal.prove ctxt [] [] action_goal
              (fn _ =>
                  forward_tac ctxt [@{thm le_natI}] 1
                  THEN fin ctxt
                  THEN REPEAT (resolve_tac ctxt [@{thm natE}] 1
                               THEN step ctxt tc_lemma)
                  THEN (step ctxt tc_lemma)
              )
    in (action_lemma, tc_lemma, fvs, r)
  end

(*
Returns the sum renaming, the goal for type_checking, and the actual lemmas
for the left part of the sum.
*)
 fun sum_ren_aux e e' ctxt =
  let val env = Variable.variant_frees ctxt [] [("env",@{typ i})] |> hd |> Free
      val (left_action_lemma,left_tc_lemma,_,r) = ren_thm e e' ctxt
      val (sum_ren,sum_goal_tc) = sum_tc_goal r e e' env
      val setV = Variable.variant_frees ctxt [] [("A",@{typ i})] |> hd |> Free
      fun hyp en = mem_ en (list_ setV)
  in (sum_ren,
      freeName env,
      Logic.list_implies (map (fn e => e |> hyp |> tp) [env], sum_goal_tc),
      left_tc_lemma,
      left_action_lemma)
end

fun sum_tc_lemma rho rho' ctxt =
  let val (sum_ren, envVar, tc_goal, left_tc_lemma, left_action_lemma) = sum_ren_aux rho rho' ctxt
      val (goal,fvs) = sum_action_goal sum_ren rho rho' ctxt
      val r = mk_ren rho rho' ctxt
  in (sum_ren, goal,envVar, r,left_tc_lemma, left_action_lemma ,fvs, Goal.prove ctxt [] [] tc_goal
               (fn _ =>
            resolve_tac ctxt [@{thm sum_type_id_aux2}] 1
            THEN asm_simp_tac ctxt 4
            THEN simp_tac ctxt 1
            THEN resolve_tac ctxt [left_tc_lemma] 1
            THEN (fin ctxt)
            THEN (fin ctxt)
  ))
  end

fun sum_rename rho rho' ctxt =
  let
    val (_, goal, _, left_rename, left_tc_lemma, left_action_lemma, fvs, sum_tc_lemma) =
          sum_tc_lemma rho rho' ctxt
    val action_lemma = fix_vars left_action_lemma fvs ctxt
  in (sum_tc_lemma, Goal.prove ctxt [] [] goal
    (fn _ => resolve_tac ctxt [@{thm sum_action_id_aux}] 1
            THEN (simp_tac ctxt 4)
            THEN (simp_tac ctxt 1)
            THEN (resolve_tac ctxt [left_tc_lemma]  1)
            THEN (asm_full_simp_tac ctxt 1)
            THEN (asm_full_simp_tac ctxt 1)
            THEN (simp_tac ctxt 1)
            THEN (simp_tac ctxt 1)
            THEN (simp_tac ctxt 1)
            THEN (full_simp_tac ctxt 1)
            THEN (resolve_tac ctxt [action_lemma] 1)
            THEN (blast_tac ctxt  1)
            THEN (full_simp_tac ctxt  1)
            THEN (full_simp_tac ctxt  1)

   ), fvs, left_rename
   )
end ;
end

Theory M_Basic_No_Repl

theory M_Basic_No_Repl
  imports "ZF-Constructible.Relative"
begin

txt‹This locale is exactly locale‹M_basic› without its only replacement
instance.›

locale M_basic_no_repl = M_trivial +
  assumes Inter_separation:
    "M(A) ==> separation(M, λx. ∀y[M]. y∈A ⟶ x∈y)"
    and Diff_separation:
    "M(B) ==> separation(M, λx. x ∉ B)"
    and cartprod_separation:
    "[| M(A); M(B) |]
      ==> separation(M, λz. ∃x[M]. x∈A & (∃y[M]. y∈B & pair(M,x,y,z)))"
    and image_separation:
    "[| M(A); M(r) |]
      ==> separation(M, λy. ∃p[M]. p∈r & (∃x[M]. x∈A & pair(M,x,y,p)))"
    and converse_separation:
    "M(r) ==> separation(M,
         λz. ∃p[M]. p∈r & (∃x[M]. ∃y[M]. pair(M,x,y,p) & pair(M,y,x,z)))"
    and restrict_separation:
    "M(A) ==> separation(M, λz. ∃x[M]. x∈A & (∃y[M]. pair(M,x,y,z)))"
    and comp_separation:
    "[| M(r); M(s) |]
      ==> separation(M, λxz. ∃x[M]. ∃y[M]. ∃z[M]. ∃xy[M]. ∃yz[M].
                  pair(M,x,z,xz) & pair(M,x,y,xy) & pair(M,y,z,yz) &
                  xy∈s & yz∈r)"
    and pred_separation:
    "[| M(r); M(x) |] ==> separation(M, λy. ∃p[M]. p∈r & pair(M,y,x,p))"
    and Memrel_separation:
    "separation(M, λz. ∃x[M]. ∃y[M]. pair(M,x,y,z) & x ∈ y)"
    and is_recfun_separation:
    ― ‹for well-founded recursion: used to prove ‹is_recfun_equal››
    "[| M(r); M(f); M(g); M(a); M(b) |]
     ==> separation(M,
            λx. ∃xa[M]. ∃xb[M].
                pair(M,x,a,xa) & xa ∈ r & pair(M,x,b,xb) & xb ∈ r &
                (∃fx[M]. ∃gx[M]. fun_apply(M,f,x,fx) & fun_apply(M,g,x,gx) &
                                   fx ≠ gx))"
    and power_ax:         "power_ax(M)"

lemma (in M_basic_no_repl) cartprod_iff:
  "[| M(A); M(B); M(C) |]
      ==> cartprod(M,A,B,C) ⟷
          (∃p1[M]. ∃p2[M]. powerset(M,A ∪ B,p1) & powerset(M,p1,p2) &
                   C = {z ∈ p2. ∃x∈A. ∃y∈B. z = <x,y>})"
  apply (simp add: Pair_def cartprod_def, safe)
    defer 1
    apply (simp add: powerset_def)
   apply blast
  txt‹Final, difficult case: the left-to-right direction of the theorem.›
  apply (insert power_ax, simp add: power_ax_def)
  apply (frule_tac x="A ∪ B" and P="λx. rex(M,Q(x))" for Q in rspec)
   apply (blast, clarify)
  apply (drule_tac x=z and P="λx. rex(M,Q(x))" for Q in rspec)
   apply assumption
  apply (blast intro: cartprod_iff_lemma)
  done

lemma (in M_basic_no_repl) cartprod_closed_lemma:
  "[| M(A); M(B) |] ==> ∃C[M]. cartprod(M,A,B,C)"
  apply (simp del: cartprod_abs add: cartprod_iff)
  apply (insert power_ax, simp add: power_ax_def)
  apply (frule_tac x="A ∪ B" and P="λx. rex(M,Q(x))" for Q in rspec)
   apply (blast, clarify)
  apply (drule_tac x=z and P="λx. rex(M,Q(x))" for Q in rspec, auto)
  apply (intro rexI conjI, simp+)
  apply (insert cartprod_separation [of A B], simp)
  done

text‹All the lemmas above are necessary because Powerset is not absolute.
      I should have used Replacement instead!›
lemma (in M_basic_no_repl) cartprod_closed [intro,simp]:
  "[| M(A); M(B) |] ==> M(A*B)"
  by (frule cartprod_closed_lemma, assumption, force)

lemma (in M_basic_no_repl) sum_closed [intro,simp]:
  "[| M(A); M(B) |] ==> M(A+B)"
  by (simp add: sum_def)

lemma (in M_basic_no_repl) sum_abs [simp]:
  "[| M(A); M(B); M(Z) |] ==> is_sum(M,A,B,Z) ⟷ (Z = A+B)"
  by (simp add: is_sum_def sum_def singleton_0 nat_into_M)

lemma (in M_basic_no_repl) M_converse_iff:
  "M(r) ==>
      converse(r) =
      {z ∈ ⋃(⋃(r)) * ⋃(⋃(r)).
       ∃p∈r. ∃x[M]. ∃y[M]. p = ⟨x,y⟩ & z = ⟨y,x⟩}"
  apply (rule equalityI)
   prefer 2 apply (blast dest: transM, clarify, simp)
  apply (simp add: Pair_def)
  apply (blast dest: transM)
  done

lemma (in M_basic_no_repl) converse_closed [intro,simp]:
  "M(r) ==> M(converse(r))"
  apply (simp add: M_converse_iff)
  apply (insert converse_separation [of r], simp)
  done

lemma (in M_basic_no_repl) converse_abs [simp]:
  "[| M(r); M(z) |] ==> is_converse(M,r,z) ⟷ z = converse(r)"
  apply (simp add: is_converse_def)
  apply (rule iffI)
   prefer 2 apply blast
  apply (rule M_equalityI)
    apply simp
    apply (blast dest: transM)+
  done


subsubsection ‹image, preimage, domain, range›

lemma (in M_basic_no_repl) image_closed [intro,simp]:
  "[| M(A); M(r) |] ==> M(r``A)"
  apply (simp add: image_iff_Collect)
  apply (insert image_separation [of A r], simp)
  done

lemma (in M_basic_no_repl) vimage_abs [simp]:
  "[| M(r); M(A); M(z) |] ==> pre_image(M,r,A,z) ⟷ z = r-``A"
  apply (simp add: pre_image_def)
  apply (rule iffI)
   apply (blast intro!: equalityI dest: transM, blast)
  done

lemma (in M_basic_no_repl) vimage_closed [intro,simp]:
  "[| M(A); M(r) |] ==> M(r-``A)"
  by (simp add: vimage_def)


subsubsection‹Domain, range and field›

lemma (in M_basic_no_repl) domain_closed [intro,simp]:
  "M(r) ==> M(domain(r))"
  apply (simp add: domain_eq_vimage)
  done

lemma (in M_basic_no_repl) range_closed [intro,simp]:
  "M(r) ==> M(range(r))"
  apply (simp add: range_eq_image)
  done

lemma (in M_basic_no_repl) field_abs [simp]:
  "[| M(r); M(z) |] ==> is_field(M,r,z) ⟷ z = field(r)"
  by (simp add: is_field_def field_def)

lemma (in M_basic_no_repl) field_closed [intro,simp]:
  "M(r) ==> M(field(r))"
  by (simp add: field_def)


subsubsection‹Relations, functions and application›

lemma (in M_basic_no_repl) apply_closed [intro,simp]:
  "[|M(f); M(a)|] ==> M(f`a)"
  by (simp add: apply_def)

lemma (in M_basic_no_repl) apply_abs [simp]:
  "[| M(f); M(x); M(y) |] ==> fun_apply(M,f,x,y) ⟷ f`x = y"
  apply (simp add: fun_apply_def apply_def, blast)
  done

lemma (in M_basic_no_repl) injection_abs [simp]:
  "[| M(A); M(f) |] ==> injection(M,A,B,f) ⟷ f ∈ inj(A,B)"
  apply (simp add: injection_def apply_iff inj_def)
  apply (blast dest: transM [of _ A])
  done

lemma (in M_basic_no_repl) surjection_abs [simp]:
  "[| M(A); M(B); M(f) |] ==> surjection(M,A,B,f) ⟷ f ∈ surj(A,B)"
  by (simp add: surjection_def surj_def)

lemma (in M_basic_no_repl) bijection_abs [simp]:
  "[| M(A); M(B); M(f) |] ==> bijection(M,A,B,f) ⟷ f ∈ bij(A,B)"
  by (simp add: bijection_def bij_def)


subsubsection‹Composition of relations›

lemma (in M_basic_no_repl) M_comp_iff:
  "[| M(r); M(s) |]
      ==> r O s =
          {xz ∈ domain(s) * range(r).
            ∃x[M]. ∃y[M]. ∃z[M]. xz = ⟨x,z⟩ & ⟨x,y⟩ ∈ s & ⟨y,z⟩ ∈ r}"
  apply (simp add: comp_def)
  apply (rule equalityI)
   apply clarify
   apply simp
   apply  (blast dest:  transM)+
  done

lemma (in M_basic_no_repl) comp_closed [intro,simp]:
  "[| M(r); M(s) |] ==> M(r O s)"
  apply (simp add: M_comp_iff)
  apply (insert comp_separation [of r s], simp)
  done

lemma (in M_basic_no_repl) composition_abs [simp]:
  "[| M(r); M(s); M(t) |] ==> composition(M,r,s,t) ⟷ t = r O s"
  apply safe
  txt‹Proving term‹composition(M, r, s, r O s)››
   prefer 2
   apply (simp add: composition_def comp_def)
   apply (blast dest: transM)
  txt‹Opposite implication›
  apply (rule M_equalityI)
    apply (simp add: composition_def comp_def)
    apply (blast del: allE dest: transM)+
  done

text‹no longer needed›
lemma (in M_basic_no_repl) restriction_is_function:
  "[| restriction(M,f,A,z); function(f); M(f); M(A); M(z) |]
      ==> function(z)"
  apply (simp add: restriction_def ball_iff_equiv)
  apply (unfold function_def, blast)
  done

lemma (in M_basic_no_repl) restrict_closed [intro,simp]:
  "[| M(A); M(r) |] ==> M(restrict(r,A))"
  apply (simp add: M_restrict_iff)
  apply (insert restrict_separation [of A], simp)
  done

lemma (in M_basic_no_repl) Inter_closed [intro,simp]:
  "M(A) ==> M(⋂(A))"
  by (insert Inter_separation, simp add: Inter_def)

lemma (in M_basic_no_repl) Int_closed [intro,simp]:
  "[| M(A); M(B) |] ==> M(A ∩ B)"
  apply (subgoal_tac "M({A,B})")
   apply (frule Inter_closed, force+)
  done

lemma (in M_basic_no_repl) Diff_closed [intro,simp]:
  "[|M(A); M(B)|] ==> M(A-B)"
  by (insert Diff_separation, simp add: Diff_def)

subsubsection‹Some Facts About Separation Axioms›

lemma (in M_basic_no_repl) separation_conj:
  "[|separation(M,P); separation(M,Q)|] ==> separation(M, λz. P(z) & Q(z))"
  by (simp del: separation_closed
      add: separation_iff Collect_Int_Collect_eq [symmetric])

lemma (in M_basic_no_repl) separation_disj:
  "[|separation(M,P); separation(M,Q)|] ==> separation(M, λz. P(z) | Q(z))"
  by (simp del: separation_closed
      add: separation_iff Collect_Un_Collect_eq [symmetric])

lemma (in M_basic_no_repl) separation_neg:
  "separation(M,P) ==> separation(M, λz. ~P(z))"
  by (simp del: separation_closed
      add: separation_iff Diff_Collect_eq [symmetric])

lemma (in M_basic_no_repl) separation_imp:
  "[|separation(M,P); separation(M,Q)|]
      ==> separation(M, λz. P(z) ⟶ Q(z))"
  by (simp add: separation_neg separation_disj not_disj_iff_imp [symmetric])

text‹This result is a hint of how little can be done without the Reflection
  Theorem.  The quantifier has to be bounded by a set.  We also need another
  instance of Separation!›
lemma (in M_basic_no_repl) separation_rall:
  "[|M(Y); ∀y[M]. separation(M, λx. P(x,y));
        ∀z[M]. strong_replacement(M, λx y. y = {u ∈ z . P(u,x)})|]
      ==> separation(M, λx. ∀y[M]. y∈Y ⟶ P(x,y))"
  apply (simp del: separation_closed rall_abs
      add: separation_iff Collect_rall_eq)
  apply (blast intro!:  RepFun_closed dest: transM)
  done


subsubsection‹Functions and function space›

lemma (in M_basic_no_repl) succ_fun_eq2:
  "[|M(B); M(n->B)|] ==>
      succ(n) -> B =
      ⋃{z. p ∈ (n->B)*B, ∃f[M]. ∃b[M]. p = <f,b> & z = {cons(<n,b>, f)}}"
  apply (simp add: succ_fun_eq)
  apply (blast dest: transM)
  done

(* lemma (in M_basic_no_repl) funspace_succ:
     "[|M(n); M(B); M(n->B) |] ==> M(succ(n) -> B)"
apply (insert funspace_succ_replacement [of n], simp)
apply (force simp add: succ_fun_eq2 univalent_def)
done

text‹term‹M› contains all finite function spaces.  Needed to prove the
absoluteness of transitive closure.  See the definition of
‹rtrancl_alt› in in ‹WF_absolute.thy›.›
lemma (in M_basic_no_repl) finite_funspace_closed [intro,simp]:
     "[|n∈nat; M(B)|] ==> M(n->B)"
apply (induct_tac n, simp)
apply (simp add: funspace_succ nat_into_M)
done
 *)

lemma (in M_basic_no_repl) list_case'_closed [intro,simp]:
  "[|M(k); M(a); ∀x[M]. ∀y[M]. M(b(x,y))|] ==> M(list_case'(a,b,k))"
  apply (case_tac "quasilist(k)")
   apply (simp add: quasilist_def, force)
  apply (simp add: non_list_case)
  done

lemma (in M_basic_no_repl) tl'_closed: "M(x) ==> M(tl'(x))"
  apply (simp add: tl'_def)
  apply (force simp add: quasilist_def)
  done

sublocale M_basic ⊆ mbnr:M_basic_no_repl
  using Inter_separation Diff_separation cartprod_separation image_separation
    converse_separation restrict_separation comp_separation pred_separation
    Memrel_separation is_recfun_separation power_ax by unfold_locales

end
body>

Theory Recursion_Thms

section‹Some enhanced theorems on recursion›

theory Recursion_Thms
  imports "ZF-Constructible.Datatype_absolute"

begin

― ‹Removing arities from inherited simpset›
declare arity_And [simp del] arity_Or[simp del] arity_Implies[simp del]
  arity_Exists[simp del] arity_Iff[simp del]
  arity_subset_fm [simp del] arity_ordinal_fm[simp del] arity_transset_fm[simp del]

text‹We prove results concerning definitions by well-founded
recursion on some relation term‹R› and its transitive closure
term‹R^*››
  (* Restrict the relation r to the field A*A *)

lemma fld_restrict_eq : "a ∈ A ⟹ (r ∩ A×A)-``{a} = (r-``{a} ∩ A)"
  by(force)

lemma fld_restrict_mono : "relation(r) ⟹ A ⊆ B ⟹ r ∩ A×A ⊆ r ∩ B×B"
  by(auto)

lemma fld_restrict_dom :
  assumes "relation(r)" "domain(r) ⊆ A" "range(r)⊆ A"
  shows "r∩ A×A = r"
proof (rule equalityI,blast,rule subsetI)
  { fix x
    assume xr: "x ∈ r"
    from xr assms have "∃ a b . x = ⟨a,b⟩" by (simp add: relation_def)
    then obtain a b where "⟨a,b⟩ ∈ r" "⟨a,b⟩ ∈ r∩A×A" "x ∈ r∩A×A"
      using assms xr
      by force
    then have "x∈ r ∩ A×A" by simp
  }
  then show "x ∈ r ⟹ x∈ r∩A×A" for x .
qed

definition tr_down :: "[i,i] ⇒ i"
  where "tr_down(r,a) = (r^+)-``{a}"

lemma tr_downD : "x ∈ tr_down(r,a) ⟹ ⟨x,a⟩ ∈ r^+"
  by (simp add: tr_down_def vimage_singleton_iff)

lemma pred_down : "relation(r) ⟹ r-``{a} ⊆ tr_down(r,a)"
  by(simp add: tr_down_def vimage_mono r_subset_trancl)

lemma tr_down_mono : "relation(r) ⟹ x ∈ r-``{a} ⟹ tr_down(r,x) ⊆ tr_down(r,a)"
  by(rule subsetI,simp add:tr_down_def,auto dest: underD,force simp add: underI r_into_trancl trancl_trans)

lemma rest_eq :
  assumes "relation(r)" and "r-``{a} ⊆ B" and "a ∈ B"
  shows "r-``{a} = (r∩B×B)-``{a}"
proof (intro equalityI subsetI)
  fix x
  assume "x ∈ r-``{a}"
  then
  have "x ∈ B" using assms by (simp add: subsetD)
  from ‹x∈ r-``{a}›
  have "⟨x,a⟩ ∈ r" using underD by simp
  then
  show "x ∈ (r∩B×B)-``{a}" using ‹x∈B› ‹a∈B› underI by simp
next
  from assms
  show "x ∈ r -`` {a}" if  "x ∈ (r ∩ B×B) -`` {a}" for x
    using vimage_mono that by auto
qed

lemma wfrec_restr_eq : "r' = r ∩ A×A ⟹ wfrec[A](r,a,H) = wfrec(r',a,H)"
  by(simp add:wfrec_on_def)

lemma wfrec_restr :
  assumes rr: "relation(r)" and wfr:"wf(r)"
  shows  "a ∈ A ⟹ tr_down(r,a) ⊆ A ⟹ wfrec(r,a,H) = wfrec[A](r,a,H)"
proof (induct a arbitrary:A rule:wf_induct_raw[OF wfr] )
  case (1 a)
  have wfRa : "wf[A](r)"
    using wf_subset wfr wf_on_def Int_lower1 by simp
  from pred_down rr
  have "r -`` {a} ⊆ tr_down(r, a)" .
  with 1
  have "r-``{a} ⊆ A" by (force simp add: subset_trans)
  {
    fix x
    assume x_a : "x ∈ r-``{a}"
    with ‹r-``{a} ⊆ A›
    have "x ∈ A" ..
    from pred_down rr
    have b : "r -``{x} ⊆ tr_down(r,x)" .
    then
    have "tr_down(r,x) ⊆ tr_down(r,a)"
      using tr_down_mono x_a rr by simp
    with 1
    have "tr_down(r,x) ⊆ A" using subset_trans by force
    have "⟨x,a⟩ ∈ r" using x_a  underD by simp
    with 1 ‹tr_down(r,x) ⊆ A› ‹x ∈ A›
    have "wfrec(r,x,H) = wfrec[A](r,x,H)" by simp
  }
  then
  have "x∈ r-``{a} ⟹ wfrec(r,x,H) =  wfrec[A](r,x,H)" for x  .
  then
  have Eq1 :"(λ x ∈ r-``{a} . wfrec(r,x,H)) = (λ x ∈ r-``{a} . wfrec[A](r,x,H))"
    using lam_cong by simp

  from assms
  have "wfrec(r,a,H) = H(a,λ x ∈ r-``{a} . wfrec(r,x,H))" by (simp add:wfrec)
  also
  have "... = H(a,λ x ∈ r-``{a} . wfrec[A](r,x,H))"
    using assms Eq1 by simp
  also from 1 ‹r-``{a} ⊆ A›
  have "... = H(a,λ x ∈ (r∩A×A)-``{a} . wfrec[A](r,x,H))"
    using assms rest_eq  by simp
  also from ‹a∈A›
  have "... = H(a,λ x ∈ (r-``{a})∩A . wfrec[A](r,x,H))"
    using fld_restrict_eq by simp
  also from ‹a∈A› ‹wf[A](r)›
  have "... = wfrec[A](r,a,H)" using wfrec_on by simp
  finally show ?case .
qed

lemmas wfrec_tr_down = wfrec_restr[OF _ _ _ subset_refl]

lemma wfrec_trans_restr : "relation(r) ⟹ wf(r) ⟹ trans(r) ⟹ r-``{a}⊆A ⟹ a ∈ A ⟹
  wfrec(r, a, H) = wfrec[A](r, a, H)"
  by(subgoal_tac "tr_down(r,a) ⊆ A",auto simp add : wfrec_restr tr_down_def trancl_eq_r)


lemma field_trancl : "field(r^+) = field(r)"
  by (blast intro: r_into_trancl dest!: trancl_type [THEN subsetD])

definition
  Rrel :: "[i⇒i⇒o,i] ⇒ i" where
  "Rrel(R,A) ≡ {z∈A×A. ∃x y. z = ⟨x, y⟩ ∧ R(x,y)}"

lemma RrelI : "x ∈ A ⟹ y ∈ A ⟹ R(x,y) ⟹ ⟨x,y⟩ ∈ Rrel(R,A)"
  unfolding Rrel_def by simp

lemma Rrel_mem: "Rrel(mem,x) = Memrel(x)"
  unfolding Rrel_def Memrel_def ..

lemma relation_Rrel: "relation(Rrel(R,d))"
  unfolding Rrel_def relation_def by simp

lemma field_Rrel: "field(Rrel(R,d)) ⊆  d"
  unfolding Rrel_def by auto

lemma Rrel_mono : "A ⊆ B ⟹ Rrel(R,A) ⊆ Rrel(R,B)"
  unfolding Rrel_def by blast

lemma Rrel_restr_eq : "Rrel(R,A) ∩ B×B = Rrel(R,A∩B)"
  unfolding Rrel_def by blast

(* now a consequence of the previous lemmas *)
lemma field_Memrel : "field(Memrel(A)) ⊆ A"
  (* unfolding field_def using Ordinal.Memrel_type by blast *)
  using Rrel_mem field_Rrel by blast

lemma restrict_trancl_Rrel:
  assumes "R(w,y)"
  shows "restrict(f,Rrel(R,d)-``{y})`w
       = restrict(f,(Rrel(R,d)^+)-``{y})`w"
proof (cases "y∈d")
  let ?r="Rrel(R,d)" and ?s="(Rrel(R,d))^+"
  case True
  show ?thesis
  proof (cases "w∈d")
    case True
    with ‹y∈d› assms
    have "⟨w,y⟩∈?r"
      unfolding Rrel_def by blast
    then
    have "⟨w,y⟩∈?s"
      using r_subset_trancl[of ?r] relation_Rrel[of R d] by blast
    with ‹⟨w,y⟩∈?r›
    have "w∈?r-``{y}" "w∈?s-``{y}"
      using vimage_singleton_iff by simp_all
    then
    show ?thesis by simp
  next
    case False
    then
    have "w∉domain(restrict(f,?r-``{y}))"
      using subsetD[OF field_Rrel[of R d]] by auto
    moreover from ‹w∉d›
    have "w∉domain(restrict(f,?s-``{y}))"
      using subsetD[OF field_Rrel[of R d], of w] field_trancl[of ?r]
        fieldI1[of w y ?s] by auto
    ultimately
    have "restrict(f,?r-``{y})`w = 0" "restrict(f,?s-``{y})`w = 0"
      unfolding apply_def by auto
    then show ?thesis by simp
  qed
next
  let ?r="Rrel(R,d)"
  let ?s="?r^+"
  case False
  then
  have "?r-``{y}=0"
    unfolding Rrel_def by blast
  then
  have "w∉?r-``{y}" by simp
  with ‹y∉d› assms
  have "y∉field(?s)"
    using field_trancl subsetD[OF field_Rrel[of R d]] by force
  then
  have "w∉?s-``{y}"
    using vimage_singleton_iff by blast
  with ‹w∉?r-``{y}›
  show ?thesis by simp
qed

lemma restrict_trans_eq:
  assumes "w ∈ y"
  shows "restrict(f,Memrel(eclose({x}))-``{y})`w
       = restrict(f,(Memrel(eclose({x}))^+)-``{y})`w"
  using assms restrict_trancl_Rrel[of mem ] Rrel_mem by (simp)

lemma wf_eq_trancl:
  assumes "⋀ f y . H(y,restrict(f,R-``{y})) = H(y,restrict(f,R^+-``{y}))"
  shows  "wfrec(R, x, H) = wfrec(R^+, x, H)" (is "wfrec(?r,_,_) = wfrec(?r',_,_)")
proof -
  have "wfrec(R, x, H) = wftrec(?r^+, x, λy f. H(y, restrict(f,?r-``{y})))"
    unfolding wfrec_def ..
  also
  have " ... = wftrec(?r^+, x, λy f. H(y, restrict(f,(?r^+)-``{y})))"
    using assms by simp
  also
  have " ... =  wfrec(?r^+, x, H)"
    unfolding wfrec_def using trancl_eq_r[OF relation_trancl trans_trancl] by simp
  finally
  show ?thesis .
qed

lemma transrec_equal_on_Ord:
  assumes
    "⋀x f . Ord(x) ⟹ foo(x,f) = bar(x,f)"
    "Ord(α)"
  shows
    "transrec(α, foo) = transrec(α, bar)"
proof -
  have "transrec(β,foo) = transrec(β,bar)" if "Ord(β)" for β
    using that
  proof (induct rule:trans_induct)
    case (step β)
    have "transrec(β, foo) = foo(β, λx∈β. transrec(x, foo))"
      using def_transrec[of "λx. transrec(x, foo)" foo] by blast
    also from assms and step
    have " … = bar(β, λx∈β. transrec(x, foo))"
      by simp
    also from step
    have " … = bar(β, λx∈β. transrec(x, bar))"
      by (auto)
    also
    have " … = transrec(β, bar)"
      using def_transrec[of "λx. transrec(x, bar)" bar, symmetric]
      by blast
    finally
    show "transrec(β, foo) = transrec(β, bar)" .
  qed
  with assms
  show ?thesis by simp
qed

― ‹Next theorem is very similar to @{thm transrec_equal_on_Ord}›
lemma (in M_eclose) transrec_equal_on_M:
  assumes
    "⋀x f . M(x) ⟹ M(f) ⟹ foo(x,f) = bar(x,f)"
    "⋀β. M(β) ⟹ transrec_replacement(M,is_foo,β)" "relation2(M,is_foo,foo)"
    "strong_replacement(M, λx y. y = ⟨x, transrec(x, foo)⟩)"
    "∀x[M]. ∀g[M]. function(g) ⟶ M(foo(x,g))"
    "M(α)" "Ord(α)"
  shows
    "transrec(α, foo) = transrec(α, bar)"
proof -
  have "M(transrec(x, foo))" if "Ord(x)" and "M(x)" for x
    using that assms transrec_closed[of is_foo]
    by simp
  have "transrec(β,foo) = transrec(β,bar)" "M(transrec(β,foo))" if "Ord(β)" "M(β)" for β
    using that
  proof (induct rule:trans_induct)
    case (step β)
    moreover
    assume "M(β)"
    moreover
    note ‹Ord(β)⟹ M(β) ⟹ M(transrec(β, foo))›
    ultimately
    show "M(transrec(β, foo))" by blast
    with step ‹M(β)› ‹⋀x. Ord(x)⟹ M(x) ⟹ M(transrec(x, foo))›
      ‹strong_replacement(M, λx y. y = ⟨x, transrec(x, foo)⟩)›
    have "M(λx∈β. transrec(x, foo))"
      using Ord_in_Ord transM[of _ β]
      by (rule_tac lam_closed) auto
    have "transrec(β, foo) = foo(β, λx∈β. transrec(x, foo))"
      using def_transrec[of "λx. transrec(x, foo)" foo] by blast
    also from assms and ‹M(λx∈β. transrec(x, foo))› ‹M(β)›
    have " … = bar(β, λx∈β. transrec(x, foo))"
      by simp
    also from step and ‹M(β)›
    have " … = bar(β, λx∈β. transrec(x, bar))"
      using transM[of _ β] by (auto)
    also
    have " … = transrec(β, bar)"
      using def_transrec[of "λx. transrec(x, bar)" bar, symmetric]
      by blast
    finally
    show "transrec(β, foo) = transrec(β, bar)" .
  qed
  with assms
  show ?thesis by simp
qed


lemma ordermap_restr_eq:
  assumes "well_ord(X,r)"
  shows "ordermap(X, r) = ordermap(X, r ∩ X×X)"
proof -
  let ?A="λx . Order.pred(X, x, r)"
  let ?B="λx . Order.pred(X, x, r ∩ X × X)"
  let ?F="λx f. f `` ?A(x)"
  let ?G="λx f. f `` ?B(x)"
  let ?P="λ z. z∈X ⟶ wfrec(r ∩ X × X,z,λx f. f `` ?A(x)) = wfrec(r ∩ X × X,z,λx f. f `` ?B(x))"
  have pred_eq:
    "Order.pred(X, x, r ∩ X × X) = Order.pred(X, x, r)" if "x∈X" for x
    unfolding Order.pred_def using that by auto
  from assms
  have wf_onX:"wf(r ∩ X × X)" unfolding well_ord_def wf_on_def by simp
  {
    have "?P(z)" for z
    proof(induct rule:wf_induct[where P="?P",OF wf_onX])
      case (1 x)
      {
        assume "x∈X"
        from 1
        have lam_eq:
          "(λw∈(r ∩ X × X) -`` {x}. wfrec(r ∩ X × X, w, ?F)) =
             (λw∈(r ∩ X × X) -`` {x}. wfrec(r ∩ X × X, w, ?G))" (is "?L=?R")
        proof -
          have "wfrec(r ∩ X × X, w, ?F) = wfrec(r ∩ X × X, w, ?G)" if "w∈(r∩X×X)-``{x}" for w
            using 1 that by auto
          then show ?thesis using lam_cong[OF refl] by simp
        qed
        then
        have "wfrec(r ∩ X × X, x, ?F) = ?L `` ?A(x)"
          using wfrec[OF wf_onX,of x ?F] by simp
        also have "... =  ?R `` ?B(x)"
          using lam_eq pred_eq[OF ‹x∈_›] by simp
        also
        have "... = wfrec(r ∩ X × X, x, ?G)"
          using wfrec[OF wf_onX,of x ?G] by simp
        finally
        have "wfrec(r ∩ X × X, x, ?F) = wfrec(r ∩ X × X, x, ?G)" by simp
      }
      then
      show ?case by simp
    qed
  }
  then
  show ?thesis
    unfolding ordermap_def wfrec_on_def using Int_ac by simp
qed

end
d>

Theory Synthetic_Definition

section‹Automatic synthesis of formulas›
theory Synthetic_Definition
  imports
    Utils
  keywords
    "synthesize" :: thy_decl % "ML"
    and
    "synthesize_notc" :: thy_decl % "ML"
    and
    "generate_schematic" :: thy_decl % "ML"
    and
    "arity_theorem" :: thy_decl % "ML"
    and
    "manual_schematic" :: thy_goal_stmt % "ML"
    and
    "manual_arity" :: thy_goal_stmt % "ML"
    and
    "from_schematic"
    and
    "for"
    and
    "from_definition"
    and
    "assuming"
    and
    "intermediate"

begin

named_theorems fm_definitions "Definitions of synthetized formulas."

named_theorems iff_sats "Theorems for synthetising formulas."

named_theorems arity "Theorems for arity of formulas."

named_theorems arity_aux "Auxiliary theorems for calculating arities."

ML‹
val $` = curry ((op $) o swap)
infix $`

infix 6 &&&
val op &&& = Utils.&&&

infix 6 ***
val op *** = Utils.***

fun arity_goal intermediate def_name lthy =
  let
    val thm = Proof_Context.get_thm lthy (def_name ^ "_def")
    val (_, tm, _) = Utils.thm_concl_tm lthy (def_name ^ "_def")
    val (def, tm) = tm |> Utils.dest_eq_tms'
    fun first_lambdas (Abs (body as (_, ty, _))) =
        if ty = @{typ "i"}
          then (op ::) (Utils.dest_abs body |>> Utils.var_i ||> first_lambdas)
          else Utils.dest_abs body |> first_lambdas o #2
      | first_lambdas _ = []
    val (def, vars) = Term.strip_comb def
    val vs = vars @ first_lambdas tm
    val def = fold (op $`) vs def
    val hyps = map (fn v => Utils.mem_ v Utils.nat_ |> Utils.tp) vs
    val concl = @{const IFOL.eq(i)} $ (@{const arity} $ def) $ Var (("ar", 0), @{typ "i"})
    val g_iff = Logic.list_implies (hyps, Utils.tp concl)
    val attribs = if intermediate then [] else @{attributes [arity]}
  in
    (g_iff, "arity_" ^ def_name ^ (if intermediate then "'" else ""), attribs, thm, vs)
  end

fun manual_arity intermediate def_name pos lthy =
  let
    val (goal, thm_name, attribs, _, _) = arity_goal intermediate def_name lthy
  in
    Proof.theorem NONE (fn thmss => Utils.display "theorem" pos
                                    o Local_Theory.note ((Binding.name thm_name, attribs), hd thmss))
    [[(goal, [])]] lthy
  end

fun prove_arity thms goal ctxt =
  let
    val rules = (Named_Theorems.get ctxt named_theorems‹arity›) @
      (Named_Theorems.get ctxt named_theorems‹arity_aux›)
  in
    Goal.prove ctxt [] [] goal
    (K (rewrite_goal_tac ctxt thms 1 THEN Method.insert_tac ctxt rules 1 THEN asm_simp_tac ctxt 1))
  end

fun auto_arity intermediate def_name pos lthy =
  let
    val (goal, thm_name, attribs, def_thm, vs) = arity_goal intermediate def_name lthy
    val intermediate_text = if intermediate then "intermediate" else ""
    val help = "You can manually prove the arity_theorem by typing:\n"
             ^ "manual_arity " ^ intermediate_text ^ " for \"" ^ def_name ^ "\"\n"
    val thm = prove_arity [def_thm] goal lthy
              handle ERROR s => help ^ "\n\n" ^ s |> Exn.reraise o ERROR
    val thm = Utils.fix_vars thm (map Utils.freeName vs) lthy
  in
    Local_Theory.note ((Binding.name thm_name, attribs), [thm]) lthy |> Utils.display "theorem" pos
  end

fun prove_tc_form goal thms ctxt =
  Goal.prove ctxt [] [] goal (K (rewrite_goal_tac ctxt thms 1 THEN auto_tac ctxt))

fun prove_sats_tm thm_auto thms goal ctxt =
  let
    val ctxt' = ctxt |> Simplifier.add_simp (hd thm_auto)
  in
    Goal.prove ctxt [] [] goal
    (K (rewrite_goal_tac ctxt thms 1 THEN PARALLEL_ALLGOALS (asm_simp_tac ctxt')))
  end

fun prove_sats_iff goal ctxt = Goal.prove ctxt [] [] goal (K (asm_simp_tac ctxt 1))

fun is_mem (@{const mem} $ _ $  _) = true
  | is_mem _ = false

fun pre_synth_thm_sats term set env vars vs lthy =
  let
    val (_, tm, ctxt1) = Utils.thm_concl_tm lthy term
    val (thm_refs, ctxt2) = Variable.import true [Proof_Context.get_thm lthy term] ctxt1 |>> #2
    val vs' = map (Thm.term_of o #2) vs
    val vars' = map (Thm.term_of o #2) vars
    val r_tm = tm |> Utils.dest_lhs_def |> fold (op $`) vs'
    val sats = @{const apply} $ (@{const satisfies} $ set $ r_tm) $ env
    val sats' = @{const IFOL.eq(i)} $ sats $ (@{const succ} $ @{const zero})
  in
    { vars = vars'
    , vs = vs'
    , sats = sats'
    , thm_refs = thm_refs
    , lthy = ctxt2
    , env = env
    , set = set
    }
  end

fun synth_thm_sats_gen name lhs hyps pos attribs aux_funs environment lthy =
  let
    val ctxt = (#prepare_ctxt aux_funs) lthy
    val ctxt = Utils.add_to_context (Utils.freeName (#set environment)) ctxt
    val (new_vs, ctxt') = (#create_variables aux_funs) (#vs environment, ctxt)
    val new_hyps = (#create_hyps aux_funs) (#vs environment, new_vs)
    val concl = (#make_concl aux_funs) (lhs, #sats environment, new_vs)
    val g_iff = Logic.list_implies (new_hyps @ hyps, Utils.tp concl)
    val thm = (#prover aux_funs) g_iff ctxt'
    val thm = Utils.fix_vars thm (map Utils.freeName ((#vars environment) @ new_vs)) lthy
  in
    Local_Theory.note ((name, attribs), [thm]) lthy |> Utils.display "theorem" pos
  end

fun synth_thm_sats_iff def_name lhs hyps pos environment =
  let
    val subst = Utils.zip_with (I *** I) (#vs environment)
    fun subst_nth (@{const "nth"} $ v $ _) new_vs = AList.lookup (op =) (subst new_vs) v |> the
      | subst_nth (t1 $ t2) new_vs = (subst_nth t1 new_vs) $ (subst_nth t2 new_vs)
      | subst_nth (Abs (v, ty, t)) new_vs = Abs (v, ty, subst_nth t new_vs)
      | subst_nth t _ = t
    val name = Binding.name (def_name ^ "_iff_sats")
    val iff_sats_attrib = @{attributes [iff_sats]}
    val aux_funs = { prepare_ctxt = fold Utils.add_to_context (map Utils.freeName (#vs environment))
                   , create_variables = fn (vs, ctxt) => Variable.variant_fixes (map Utils.freeName vs) ctxt |>> map Utils.var_i
                   , create_hyps = fn (vs, new_vs) => Utils.zip_with (fn (v, nv) => Utils.eq_ (Utils.nth_ v (#env environment)) nv) vs new_vs |> map Utils.tp
                   , make_concl = fn (lhs, rhs, new_vs) => @{const IFOL.iff} $ (subst_nth lhs new_vs) $ rhs
                   , prover = prove_sats_iff
                   }
  in
    synth_thm_sats_gen name lhs hyps pos iff_sats_attrib aux_funs environment
  end

fun synth_thm_sats_fm def_name lhs hyps pos thm_auto environment =
  let
    val name = Binding.name ("sats_" ^ def_name ^ "_fm")
    val simp_attrib = @{attributes [simp]}
    val aux_funs = { prepare_ctxt = I
                   , create_variables = K [] *** I
                   , create_hyps = K []
                   , make_concl = fn (rhs, lhs, _) => @{const IFOL.iff} $ lhs $ rhs
                   , prover = prove_sats_tm thm_auto (#thm_refs environment)
                   }
  in
    synth_thm_sats_gen name lhs hyps pos simp_attrib aux_funs environment
  end

fun synth_thm_tc def_name term hyps vars pos lthy =
  let
    val (_,tm,ctxt1) = Utils.thm_concl_tm lthy term
    val (thm_refs,ctxt2) = Variable.import true [Proof_Context.get_thm lthy term] ctxt1 |>> #2
    val vars' = map (Thm.term_of o #2) vars
    val tc_attrib = @{attributes [TC]}
    val r_tm = tm |> Utils.dest_lhs_def |> fold (op $`) vars'
    val concl = @{const mem} $ r_tm $ @{const formula}
    val g = Logic.list_implies(hyps, Utils.tp concl)
    val thm = prove_tc_form g thm_refs ctxt2
    val name = Binding.name (def_name ^ "_fm_type")
    val thm = Utils.fix_vars thm (map Utils.freeName vars') ctxt2
  in
    Local_Theory.note ((name, tc_attrib), [thm]) lthy |> Utils.display "theorem" pos
  end

fun synthetic_def def_name thm_ref pos tc auto thy =
  let
    val thm = Proof_Context.get_thm thy thm_ref
    val thm_vars = rev (Term.add_vars (Thm.full_prop_of thm) [])
    val (((_,inst),thm_tms),_) = Variable.import true [thm] thy
    val vars = map (fn v => (v, the (Vars.lookup inst v))) thm_vars
    val (tm,hyps) = thm_tms |> hd |> Thm.concl_of &&& Thm.prems_of
    val (lhs,rhs) = tm |> Utils.dest_iff_tms o Utils.dest_trueprop
    val ((set,t),env) = rhs |> Utils.dest_sats_frm
    fun relevant ts (@{const mem} $ t $ _) =
          (not (t = @{term "0"})) andalso
          (not (Term.is_Free t) orelse member (op =) ts (t |> Term.dest_Free |> #1))
      | relevant _ _ = false
    val t_vars = sort_strings (Term.add_free_names t [])
    val vs = filter (Ord_List.member String.compare t_vars o #1 o #1 o #1) vars
    val at = fold_rev (lambda o Thm.term_of o #2) vs t
    val hyps' = filter (relevant t_vars o Utils.dest_trueprop) hyps
    val def_attrs = @{attributes [fm_definitions]}
  in
    Local_Theory.define ((Binding.name (def_name ^ "_fm"), NoSyn),
                        ((Binding.name (def_name ^ "_fm_def"), def_attrs), at)) thy
    |>> (#2 #> I *** single) |> Utils.display "theorem" pos |>
    (if tc then synth_thm_tc def_name (def_name ^ "_fm_def") hyps' vs pos else I) |>
    (if auto then
      pre_synth_thm_sats (def_name ^ "_fm_def") set env vars vs
      #> I &&& #lthy
      #> #1 &&& uncurry (synth_thm_sats_fm def_name lhs hyps pos thm_tms)
      #> uncurry (synth_thm_sats_iff def_name lhs hyps pos)
    else I)
  end

fun prove_schematic thms goal ctxt =
  let
    val rules = Named_Theorems.get ctxt named_theorems‹iff_sats›
  in
    Goal.prove ctxt [] [] goal
    (K (rewrite_goal_tac ctxt thms 1 THEN REPEAT1 (CHANGED (resolve_tac ctxt rules 1 ORELSE asm_simp_tac ctxt 1))))
  end

val valid_assumptions = [ ("nonempty", Utils.mem_ @{term "0"})
                        ]

fun pre_schematic_def target assuming lthy =
let
    val thm = Proof_Context.get_thm lthy (target ^ "_def")
    val (vars, tm, ctxt1) = Utils.thm_concl_tm lthy (target ^ "_def")
    val (const, tm) = tm |> Utils.dest_eq_tms' o Utils.dest_trueprop |>> #1 o strip_comb
    val t_vars = sort_strings (Term.add_free_names tm [])
    val vs = List.filter (#1 #> #1 #> #1 #> Ord_List.member String.compare t_vars) vars
             |> List.filter ((curry op = @{typ "i"}) o #2 o #1)
             |> List.map (Utils.var_i o #1 o #1 o #1)
    fun first_lambdas (Abs (body as (_, ty, _))) =
        if ty = @{typ "i"}
          then (op ::) (Utils.dest_abs body |>> Utils.var_i ||> first_lambdas)
          else Utils.dest_abs body |> first_lambdas o #2
      | first_lambdas _ = []
    val vs = vs @ (first_lambdas tm)
    val ctxt1' = fold Utils.add_to_context (map Utils.freeName vs) ctxt1
    val (set, ctxt2) = Variable.variant_fixes ["A"] ctxt1' |>> Utils.var_i o hd
    val class = @{const "setclass"} $ set
    val (env, ctxt3) = Variable.variant_fixes ["env"] ctxt2 |>> Utils.var_i o hd
    val assumptions = filter (member (op =) assuming o #1) valid_assumptions |> map #2
    val hyps = (List.map (fn v => Utils.tp (Utils.mem_ v Utils.nat_)) vs)
               @ [Utils.tp (Utils.mem_ env (Utils.list_ set))]
               @ Utils.zip_with (fn (f,x) => Utils.tp (f x)) assumptions (replicate (length assumptions) set)
    val args = class :: map (fn v => Utils.nth_ v env) vs
    val (fm_name, ctxt4) = Variable.variant_fixes ["fm"] ctxt3 |>> hd
    val fm_type = fold (K (fn acc => Type ("fun", [@{typ "i"}, acc]))) vs @{typ "i"}
    val fm = Var ((fm_name, 0), fm_type)
    val lhs = fold (op $`) args const
    val fm_app = fold (op $`) vs fm
    val sats = @{const apply} $ (@{const satisfies} $ set $ fm_app) $ env
    val rhs = @{const IFOL.eq(i)} $ sats $ (@{const succ} $ @{const zero})
    val concl = @{const "IFOL.iff"} $ lhs $ rhs
    val schematic = Logic.list_implies (hyps, Utils.tp concl)
  in
    (schematic, ctxt4, thm, set, env, vs)
  end

fun str_join _ [] = ""
  | str_join _ [s] = s
  | str_join c (s :: ss) = s ^ c ^ (str_join c ss)

fun schematic_def def_name target assuming pos lthy =
  let
    val (schematic, ctxt, thm, set, env, vs) = pre_schematic_def target assuming lthy
    val assuming_text = if null assuming then "" else "assuming " ^ (map (fn s => "\"" ^ s ^ "\"") assuming |> str_join " ")
    val help = "You can manually prove the schematic_goal by typing:\n"
             ^ "manual_schematic [sch_name] for \"" ^ target ^ "\"" ^ assuming_text ^"\n"
             ^ "And then complete the synthesis with:\n"
             ^ "synthesize \"" ^ target ^ "\" from_schematic [sch_name]\n"
             ^ "In both commands, «sch_name» must be the same and, if ommited, will be defaulted to sats_" ^ target ^ "_fm_auto.\n"
             ^ "You can also try adding new assumptions and/or synthetizing definitions of sub-terms."
    val thm = prove_schematic [thm] schematic ctxt
              handle ERROR s => help ^ "\n\n" ^ s |> Exn.reraise o ERROR
    val thm = Utils.fix_vars thm (map Utils.freeName (set :: env :: vs)) lthy
  in
    Local_Theory.note ((Binding.name def_name, []), [thm]) lthy |> Utils.display "theorem" pos
  end

fun schematic_synthetic_def def_name target assuming pos tc auto =
    (synthetic_def def_name ("sats_" ^ def_name ^ "_fm_auto") pos tc auto)
    o (schematic_def ("sats_" ^ def_name ^ "_fm_auto") target assuming pos)

fun manual_schematic def_name target assuming pos lthy =
  let
    val (schematic, _, _, _, _, _) = pre_schematic_def target assuming lthy
  in
    Proof.theorem NONE (fn thmss => Utils.display "theorem" pos
                                    o Local_Theory.note ((Binding.name def_name, []), hd thmss))
    [[(schematic, [])]] lthy
  end
›

ML‹
local
  val simple_from_schematic_synth_constdecl =
       Parse.string --| (Parse.$$$ "from_schematic")
       >> (fn bndg => synthetic_def bndg ("sats_" ^ bndg ^ "_fm_auto"))

  val full_from_schematic_synth_constdecl =
       Parse.string -- ((Parse.$$$ "from_schematic" |-- Parse.thm))
       >> (fn (bndg,thm) => synthetic_def bndg (#1 (thm |>> Facts.ref_name)))

  val full_from_definition_synth_constdecl =
       Parse.string -- ((Parse.$$$ "from_definition" |-- Parse.string)) -- (Scan.optional (Parse.$$$ "assuming" |-- Scan.repeat Parse.string) [])
       >> (fn ((bndg,target), assuming) => schematic_synthetic_def bndg target assuming)

  val simple_from_definition_synth_constdecl =
     Parse.string -- (Parse.$$$ "from_definition" |-- (Scan.optional (Parse.$$$ "assuming" |-- Scan.repeat Parse.string)) [])
     >> (fn (bndg, assuming) => schematic_synthetic_def bndg bndg assuming)

  val synth_constdecl =
       Parse.position (full_from_schematic_synth_constdecl || simple_from_schematic_synth_constdecl
                       || full_from_definition_synth_constdecl
                       || simple_from_definition_synth_constdecl)

  val full_schematic_decl =
       Parse.string -- ((Parse.$$$ "for" |-- Parse.string)) -- (Scan.optional (Parse.$$$ "assuming" |-- Scan.repeat Parse.string) [])

  val simple_schematic_decl =
       (Parse.$$$ "for" |-- Parse.string >> (fn name => "sats_" ^ name ^ "_fm_auto") &&& I) -- (Scan.optional (Parse.$$$ "assuming" |-- Scan.repeat Parse.string) [])

  val schematic_decl = Parse.position (full_schematic_decl || simple_schematic_decl)

  val _ =
     Outer_Syntax.local_theory command_keyword‹synthesize› "ML setup for synthetic definitions"
       (synth_constdecl >> (fn (f,p) => f p true true))

  val _ =
     Outer_Syntax.local_theory command_keyword‹synthesize_notc› "ML setup for synthetic definitions"
       (synth_constdecl >> (fn (f,p) => f p false false))

  val _ = Outer_Syntax.local_theory command_keyword‹generate_schematic› "ML setup for schematic goals"
       (schematic_decl >> (fn (((bndg,target), assuming),p) => schematic_def bndg target assuming p))

  val _ = Outer_Syntax.local_theory_to_proof command_keyword‹manual_schematic› "ML setup for schematic goals"
       (schematic_decl >> (fn (((bndg,target), assuming),p) => manual_schematic bndg target assuming p))

  val arity_parser = Parse.position ((Scan.option (Parse.$$$ "intermediate") >> is_some) -- (Parse.$$$ "for" |-- Parse.string))

  val _ = Outer_Syntax.local_theory_to_proof command_keyword‹manual_arity› "ML setup for arities"
       (arity_parser >> (fn ((intermediate, target), pos) => manual_arity intermediate target pos))

  val _ = Outer_Syntax.local_theory command_keyword‹arity_theorem› "ML setup for arities"
       (arity_parser >> (fn ((intermediate, target), pos) => auto_arity intermediate target pos))

in

end
›

text‹The ML‹synthetic_def› function extracts definitions from
schematic goals. A new definition is added to the context. ›

(* example of use *)
(*
schematic_goal mem_formula_ex :
  assumes "m∈nat" "n∈ nat" "env ∈ list(M)"
  shows "nth(m,env) ∈ nth(n,env) ⟷ sats(M,?frm,env)"
  by (insert assms ; (rule sep_rules empty_iff_sats cartprod_iff_sats | simp del:sats_cartprod_fm)+)

synthesize "φ" from_schematic mem_formula_ex
*)

end

Theory Internalizations

section‹Aids to internalize formulas›

theory Internalizations
  imports
    "ZF-Constructible.DPow_absolute"
    Synthetic_Definition
    Nat_Miscellanea
begin

definition
  infinity_ax :: "(i ⇒ o) ⇒ o" where
  "infinity_ax(M) ≡
      (∃I[M]. (∃z[M]. empty(M,z) ∧ z∈I) ∧ (∀y[M]. y∈I ⟶ (∃sy[M]. successor(M,y,sy) ∧ sy∈I)))"

definition
  wellfounded_trancl :: "[i=>o,i,i,i] => o" where
  "wellfounded_trancl(M,Z,r,p) ≡
      ∃w[M]. ∃wx[M]. ∃rp[M].
               w ∈ Z & pair(M,w,p,wx) & tran_closure(M,r,rp) & wx ∈ rp"

lemma empty_intf :
  "infinity_ax(M) ⟹
  (∃z[M]. empty(M,z))"
  by (auto simp add: empty_def infinity_ax_def)

lemma Transset_intf :
  "Transset(M) ⟹  y∈x ⟹ x ∈ M ⟹ y ∈ M"
  by (simp add: Transset_def,auto)

definition
  choice_ax :: "(i⇒o) ⇒ o" where
  "choice_ax(M) ≡ ∀x[M]. ∃a[M]. ∃f[M]. ordinal(M,a) ∧ surjection(M,a,x,f)"

lemma (in M_basic) choice_ax_abs :
  "choice_ax(M) ⟷ (∀x[M]. ∃a[M]. ∃f[M]. Ord(a) ∧ f ∈ surj(a,x))"
  unfolding choice_ax_def
  by simp

txt‹Setting up notation for internalized formulas›

abbreviation
  dec10  :: i   ("10") where "10 ≡ succ(9)"
abbreviation
  dec11  :: i   ("11") where "11 ≡ succ(10)"
abbreviation
  dec12  :: i   ("12") where "12 ≡ succ(11)"
abbreviation
  dec13  :: i   ("13") where "13 ≡ succ(12)"
abbreviation
  dec14  :: i   ("14") where "14 ≡ succ(13)"
abbreviation
  dec15  :: i   ("15") where "15 ≡ succ(14)"
abbreviation
  dec16  :: i   ("16") where "16 ≡ succ(15)"
abbreviation
  dec17  :: i   ("17") where "17 ≡ succ(16)"
abbreviation
  dec18  :: i   ("18") where "18 ≡ succ(17)"
abbreviation
  dec19  :: i   ("19") where "19 ≡ succ(18)"
abbreviation
  dec20  :: i   ("20") where "20 ≡ succ(19)"
abbreviation
  dec21  :: i   ("21") where "21 ≡ succ(20)"
abbreviation
  dec22  :: i   ("22") where "22 ≡ succ(21)"
abbreviation
  dec23  :: i   ("23") where "23 ≡ succ(22)"
abbreviation
  dec24  :: i   ("24") where "24 ≡ succ(23)"
abbreviation
  dec25  :: i   ("25") where "25 ≡ succ(24)"
abbreviation
  dec26  :: i   ("26") where "26 ≡ succ(25)"
abbreviation
  dec27  :: i   ("27") where "27 ≡ succ(26)"
abbreviation
  dec28  :: i   ("28") where "28 ≡ succ(27)"
abbreviation
  dec29  :: i   ("29") where "29 ≡ succ(28)"

notation Member (‹⋅_ ∈/ _⋅›)
notation Equal (‹⋅_ =/ _⋅›)
notation Nand (‹⋅¬'(_ ∧/ _')⋅›)
notation And (‹⋅_ ∧/ _⋅›)
notation Or (‹⋅_ ∨/ _⋅›)
notation Iff (‹⋅_ ↔/ _⋅›)
notation Implies (‹⋅_ →/ _⋅›)
notation Neg (‹⋅¬_⋅›)
notation Forall (‹'(⋅∀(/_)⋅')›)
notation Exists (‹'(⋅∃(/_)⋅')›)

notation subset_fm (‹⋅_ ⊆/ _⋅›)
notation succ_fm (‹⋅succ'(_') is _⋅›)
notation empty_fm (‹⋅_ is empty⋅›)
notation fun_apply_fm (‹⋅_`_ is _⋅›)
notation big_union_fm (‹⋅⋃_ is _⋅›)
notation upair_fm (‹⋅{_,_} is _ ⋅›)
notation ordinal_fm (‹⋅_ is ordinal⋅›)


notation pair_fm (‹⋅⟨_,_⟩ is _ ⋅›)
notation composition_fm (‹⋅_ ∘ _ is _ ⋅›)
notation domain_fm (‹⋅dom'(_') is _ ⋅›)
notation range_fm (‹⋅ran'(_') is _ ⋅›)
notation union_fm (‹⋅_ ∪ _ is _ ⋅›)
notation image_fm (‹⋅_ `` _ is _ ⋅›)
notation pre_image_fm (‹⋅_ -`` _ is _ ⋅›)
notation field_fm (‹⋅fld'(_') is _ ⋅›)
notation cons_fm (‹⋅cons'(_,_') is _ ⋅›)
notation number1_fm (‹⋅_ is the number one⋅›)
notation function_fm (‹⋅_ is funct⋅›)
notation relation_fm (‹⋅_ is relat⋅›)
notation restriction_fm (‹⋅_ ↾ _ is _ ⋅›)
notation transset_fm (‹⋅_ is transitive⋅›)
notation limit_ordinal_fm (‹⋅_ is limit⋅›)
notation finite_ordinal_fm (‹⋅_ is finite ord⋅›)
notation omega_fm (‹⋅_ is ω⋅›)
notation cartprod_fm (‹⋅_ × _ is _⋅›)
notation Memrel_fm (‹⋅Memrel'(_') is _⋅›)
notation quasinat_fm (‹⋅_ is qnat⋅›)
  (* notation rtran_closure_mem_fm (‹⋅{_,_} is _ ⋅›)
notation rtran_closure_fm (‹⋅{_,_} is _ ⋅›)
notation tran_closure_fm (‹⋅_ is  ⋅›)
notation order_isomorphism_fm (‹⋅{_,_} is _ ⋅›) *)
notation Inl_fm (‹⋅Inl'(_') is _ ⋅›)
notation Inr_fm (‹⋅Inr'(_') is _ ⋅›)
notation pred_set_fm (‹⋅_-predecessors of _ are _⋅›)


abbreviation
  fm_typedfun :: "[i,i,i] ⇒ i" (‹⋅_ : _ → _⋅›) where
  "fm_typedfun(f,A,B) ≡ typed_function_fm(A,B,f)"

abbreviation
  fm_surjection :: "[i,i,i] ⇒ i" (‹⋅_ surjects _ to _⋅›) where
  "fm_surjection(f,A,B) ≡ surjection_fm(A,B,f)"

abbreviation
  fm_injection :: "[i,i,i] ⇒ i" (‹⋅_ injects _ to _⋅›) where
  "fm_injection(f,A,B) ≡ injection_fm(A,B,f)"

abbreviation
  fm_bijection :: "[i,i,i] ⇒ i" (‹⋅_ bijects _ to _⋅›) where
  "fm_bijection(f,A,B) ≡ bijection_fm(A,B,f)"

text‹We found it useful to have slightly different versions of some
results in ZF-Constructible:›
lemma nth_closed :
  assumes "env∈list(A)" "0∈A"
  shows "nth(n,env)∈A"
  using assms unfolding nth_def by (induct env; simp)

lemma conj_setclass_model_iff_sats [iff_sats]:
  "[| 0 ∈ A; nth(i,env) = x; env ∈ list(A);
       P ⟷ sats(A,p,env); env ∈ list(A) |]
       ==> (P ∧ (##A)(x)) ⟷ sats(A, p, env)"
  "[| 0 ∈ A; nth(i,env) = x; env ∈ list(A);
       P ⟷ sats(A,p,env); env ∈ list(A) |]
       ==> ((##A)(x) ∧ P) ⟷ sats(A, p, env)"
  using nth_closed[of env A i]
  by auto

lemma conj_mem_model_iff_sats [iff_sats]:
  "[| 0 ∈ A; nth(i,env) = x; env ∈ list(A);
       P ⟷ sats(A,p,env); env ∈ list(A) |]
       ==> (P ∧ x ∈ A) ⟷ sats(A, p, env)"
  "[| 0 ∈ A; nth(i,env) = x; env ∈ list(A);
       P ⟷ sats(A,p,env); env ∈ list(A) |]
       ==> (x ∈ A ∧ P) ⟷ sats(A, p, env)"
  using nth_closed[of env A i]
  by auto

(* lemma [iff_sats]:
      "[| 0 ∈ A; nth(i,env) = x; env ∈ list(A);
       P ⟷ sats(A,p,env); env ∈ list(A) |]
       ==> (x ∈ A ⟷ P) ⟷ sats(A, p, env)"
      "[| 0 ∈ A; nth(i,env) = x; env ∈ list(A);
       P ⟷ sats(A,p,env); env ∈ list(A) |]
       ==> (P ⟷ x ∈ A) ⟷ sats(A, p, env)"

      "[| 0 ∈ A; nth(i,env) = x; env ∈ list(A);
       P ⟷ sats(A,p,env); env ∈ list(A) |]
       ==> (x ∈ A ⟶ P) ⟷ sats(A, p, env)"

  using nth_closed[of env A i]
  by auto *)

lemma mem_model_iff_sats [iff_sats]:
  "[| 0 ∈ A; nth(i,env) = x; env ∈ list(A)|]
       ==> (x∈A) ⟷ sats(A, Exists(Equal(0,0)), env)"
  using nth_closed[of env A i]
  by auto

lemma subset_iff_sats[iff_sats]:
  "nth(i, env) = x ⟹ nth(j, env) = y ⟹ i∈nat ⟹ j∈nat ⟹
   env ∈ list(A) ⟹ subset(##A, x, y) ⟷ sats(A, subset_fm(i, j), env)"
  using sats_subset_fm' by simp

lemma not_mem_model_iff_sats [iff_sats]:
  "[| 0 ∈ A; nth(i,env) = x; env ∈ list(A)|]
       ==> (∀ x . x ∉ A) ⟷ sats(A, Neg(Exists(Equal(0,0))), env)"
  by auto

lemma top_iff_sats [iff_sats]:
  "env ∈ list(A) ⟹ 0 ∈ A ⟹ sats(A, Exists(Equal(0,0)), env)"
  by auto

lemma prefix1_iff_sats[iff_sats]:
  assumes
    "x ∈ nat" "env ∈ list(A)" "0 ∈ A" "a ∈ A"
  shows
    "a = nth(x,env) ⟷ sats(A, Equal(0,x+ω1), Cons(a,env))"
    "nth(x,env) = a ⟷ sats(A, Equal(x+ω1,0), Cons(a,env))"
    "a ∈ nth(x,env) ⟷ sats(A, Member(0,x+ω1), Cons(a,env))"
    "nth(x,env) ∈ a ⟷ sats(A, Member(x+ω1,0), Cons(a,env))"
  using assms nth_closed
  by simp_all

lemma prefix2_iff_sats[iff_sats]:
  assumes
    "x ∈ nat" "env ∈ list(A)" "0 ∈ A" "a ∈ A" "b ∈ A"
  shows
    "b = nth(x,env) ⟷ sats(A, Equal(1,x+ω2), Cons(a,Cons(b,env)))"
    "nth(x,env) = b ⟷ sats(A, Equal(x+ω2,1), Cons(a,Cons(b,env)))"
    "b ∈ nth(x,env) ⟷ sats(A, Member(1,x+ω2), Cons(a,Cons(b,env)))"
    "nth(x,env) ∈ b ⟷ sats(A, Member(x+ω2,1), Cons(a,Cons(b,env)))"
  using assms nth_closed
  by simp_all

lemma prefix3_iff_sats[iff_sats]:
  assumes
    "x ∈ nat" "env ∈ list(A)" "0 ∈ A" "a ∈ A" "b ∈ A" "c ∈ A"
  shows
    "c = nth(x,env) ⟷ sats(A, Equal(2,x+ω3), Cons(a,Cons(b,Cons(c,env))))"
    "nth(x,env) = c ⟷ sats(A, Equal(x+ω3,2), Cons(a,Cons(b,Cons(c,env))))"
    "c ∈ nth(x,env) ⟷ sats(A, Member(2,x+ω3), Cons(a,Cons(b,Cons(c,env))))"
    "nth(x,env) ∈ c ⟷ sats(A, Member(x+ω3,2), Cons(a,Cons(b,Cons(c,env))))"
  using assms nth_closed
  by simp_all

lemmas FOL_sats_iff = sats_Nand_iff sats_Forall_iff sats_Neg_iff sats_And_iff
  sats_Or_iff sats_Implies_iff sats_Iff_iff sats_Exists_iff

lemma nth_ConsI: "⟦nth(n,l) = x; n ∈ nat⟧ ⟹ nth(succ(n), Cons(a,l)) = x"
  by simp

lemmas nth_rules = nth_0 nth_ConsI nat_0I nat_succI
lemmas sep_rules = nth_0 nth_ConsI FOL_iff_sats function_iff_sats
  fun_plus_iff_sats successor_iff_sats
  omega_iff_sats FOL_sats_iff Replace_iff_sats

text‹Also a different compilation of lemmas (term‹sep_rules›) used in formula
 synthesis›
lemmas fm_defs =
  omega_fm_def limit_ordinal_fm_def empty_fm_def typed_function_fm_def
  pair_fm_def upair_fm_def domain_fm_def function_fm_def succ_fm_def
  cons_fm_def fun_apply_fm_def image_fm_def big_union_fm_def union_fm_def
  relation_fm_def composition_fm_def field_fm_def ordinal_fm_def range_fm_def
  transset_fm_def subset_fm_def Replace_fm_def

lemmas formulas_def [fm_definitions] = fm_defs
  is_iterates_fm_def iterates_MH_fm_def is_wfrec_fm_def is_recfun_fm_def is_transrec_fm_def
  is_nat_case_fm_def quasinat_fm_def number1_fm_def ordinal_fm_def finite_ordinal_fm_def
  cartprod_fm_def sum_fm_def Inr_fm_def Inl_fm_def
  formula_functor_fm_def
  Memrel_fm_def transset_fm_def subset_fm_def pre_image_fm_def restriction_fm_def
  list_functor_fm_def tl_fm_def quasilist_fm_def Cons_fm_def Nil_fm_def

lemmas sep_rules' [iff_sats]  = nth_0 nth_ConsI FOL_iff_sats function_iff_sats
  fun_plus_iff_sats omega_iff_sats

lemmas  more_iff_sats [iff_sats] = rtran_closure_iff_sats tran_closure_iff_sats
  is_eclose_iff_sats Inl_iff_sats Inr_iff_sats fun_apply_iff_sats cartprod_iff_sats
  Collect_iff_sats

end
v class="head">

Theory Least

section‹The binder term‹Least››
theory Least
  imports
    "Internalizations"

begin

text‹We have some basic results on the least ordinal satisfying
a predicate.›

lemma Least_Ord: "(μ α. R(α)) = (μ α. Ord(α) ∧ R(α))"
  unfolding Least_def by (simp add:lt_Ord)

lemma Ord_Least_cong:
  assumes "⋀y. Ord(y) ⟹ R(y) ⟷ Q(y)"
  shows "(μ α. R(α)) = (μ α. Q(α))"
proof -
  from assms
  have "(μ α. Ord(α) ∧ R(α)) = (μ α. Ord(α) ∧ Q(α))"
    by simp
  then
  show ?thesis using Least_Ord by simp
qed

definition
  least :: "[i⇒o,i⇒o,i] ⇒ o" where
  "least(M,Q,i) ≡ ordinal(M,i) ∧ (
         (empty(M,i) ∧ (∀b[M]. ordinal(M,b) ⟶ ¬Q(b)))
       ∨ (Q(i) ∧ (∀b[M]. ordinal(M,b) ∧ b∈i⟶ ¬Q(b))))"

definition
  least_fm :: "[i,i] ⇒ i" where
  "least_fm(q,i) ≡ And(ordinal_fm(i),
   Or(And(empty_fm(i),Forall(Implies(ordinal_fm(0),Neg(q)))),
      And(Exists(And(q,Equal(0,succ(i)))),
          Forall(Implies(And(ordinal_fm(0),Member(0,succ(i))),Neg(q))))))"

lemma least_fm_type[TC] :"i ∈ nat ⟹ q∈formula ⟹ least_fm(q,i) ∈ formula"
  unfolding least_fm_def
  by simp

(* Refactorize Formula and Relative to include the following three lemmas *)
lemmas basic_fm_simps = sats_subset_fm' sats_transset_fm' sats_ordinal_fm'

lemma sats_least_fm :
  assumes p_iff_sats:
    "⋀a. a ∈ A ⟹ P(a) ⟷ sats(A, p, Cons(a, env))"
  shows
    "⟦y ∈ nat; env ∈ list(A) ; 0∈A⟧
    ⟹ sats(A, least_fm(p,y), env) ⟷
        least(##A, P, nth(y,env))"
  using nth_closed p_iff_sats unfolding least_def least_fm_def
  by (simp add:basic_fm_simps)

lemma least_iff_sats [iff_sats]:
  assumes is_Q_iff_sats:
    "⋀a. a ∈ A ⟹ is_Q(a) ⟷ sats(A, q, Cons(a,env))"
  shows
    "⟦nth(j,env) = y; j ∈ nat; env ∈ list(A); 0∈A⟧
   ⟹ least(##A, is_Q, y) ⟷ sats(A, least_fm(q,j), env)"
  using sats_least_fm [OF is_Q_iff_sats, of j , symmetric]
  by simp

lemma least_conj: "a∈M ⟹ least(##M, λx. x∈M ∧ Q(x),a) ⟷ least(##M,Q,a)"
  unfolding least_def by simp


context M_trivial
begin

subsection‹Uniqueness, absoluteness and closure under term‹Least››

lemma unique_least:
  assumes "M(a)" "M(b)" "least(M,Q,a)" "least(M,Q,b)"
  shows "a=b"
proof -
  from assms
  have "Ord(a)" "Ord(b)"
    unfolding least_def
    by simp_all
  then
  consider (le) "a∈b" | "a=b" | (ge) "b∈a"
    using Ord_linear[OF ‹Ord(a)› ‹Ord(b)›] by auto
  then
  show ?thesis
  proof(cases)
    case le
    then show ?thesis using assms unfolding least_def by auto
  next
    case ge
    then show ?thesis using assms unfolding least_def by auto
  qed
qed

lemma least_abs:
  assumes "⋀x. Q(x) ⟹ Ord(x) ⟹ ∃y[M]. Q(y) ∧ Ord(y)" "M(a)"
  shows "least(M,Q,a) ⟷ a = (μ x. Q(x))"
  unfolding least_def
proof (cases "∀b[M]. Ord(b) ⟶ ¬ Q(b)"; intro iffI; simp add:assms)
  case True
  with assms
  have "¬ (∃i. Ord(i) ∧ Q(i)) " by blast
  then
  show "0 =(μ x. Q(x))" using Least_0 by simp
  then
  show "ordinal(M, μ x. Q(x)) ∧ (empty(M, Least(Q)) ∨ Q(Least(Q)))"
    by simp
next
  assume "∃b[M]. Ord(b) ∧ Q(b)"
  then
  obtain i where "M(i)" "Ord(i)" "Q(i)" by blast
  assume "a = (μ x. Q(x))"
  moreover
  note ‹M(a)›
  moreover from  ‹Q(i)› ‹Ord(i)›
  have "Q(μ x. Q(x))" (is ?G)
    by (blast intro:LeastI)
  moreover
  have "(∀b[M]. Ord(b) ∧ b ∈ (μ x. Q(x)) ⟶ ¬ Q(b))" (is "?H")
    using less_LeastE[of Q _ False]
    by (auto, drule_tac ltI, simp, blast)
  ultimately
  show "ordinal(M, μ x. Q(x)) ∧ (empty(M, μ x. Q(x)) ∧ (∀b[M]. Ord(b) ⟶ ¬ Q(b)) ∨ ?G ∧ ?H)"
    by simp
next
  assume 1:"∃b[M]. Ord(b) ∧ Q(b)"
  then
  obtain i where "M(i)" "Ord(i)" "Q(i)" by blast
  assume "Ord(a) ∧ (a = 0 ∧ (∀b[M]. Ord(b) ⟶ ¬ Q(b)) ∨ Q(a) ∧ (∀b[M]. Ord(b) ∧ b ∈ a ⟶ ¬ Q(b)))"
  with 1
  have "Ord(a)" "Q(a)" "∀b[M]. Ord(b) ∧ b ∈ a ⟶ ¬ Q(b)"
    by blast+
  moreover from this and assms
  have "Ord(b) ⟹ b ∈ a ⟹ ¬ Q(b)" for b
    by (auto dest:transM)
  moreover from this and ‹Ord(a)›
  have "b < a ⟹ ¬ Q(b)" for b
    unfolding lt_def using Ord_in_Ord by blast
  ultimately
  show "a = (μ x. Q(x))"
    using Least_equality by simp
qed

lemma Least_closed:
  assumes "⋀x. Q(x) ⟹ Ord(x) ⟹ ∃y[M]. Q(y) ∧ Ord(y)"
  shows "M(μ x. Q(x))"
  using assms Least_le[of Q] Least_0[of Q]
  by (cases "(∃i[M]. Ord(i) ∧ Q(i))") (force dest:transM ltD)+

text‹Older, easier to apply versions (with a simpler assumption
on term‹Q›).›
lemma least_abs':
  assumes "⋀x. Q(x) ⟹ M(x)" "M(a)"
  shows "least(M,Q,a) ⟷ a = (μ x. Q(x))"
  using assms least_abs[of Q] by auto

lemma Least_closed':
  assumes "⋀x. Q(x) ⟹ M(x)"
  shows "M(μ x. Q(x))"
  using assms Least_closed[of Q] by auto

end ― ‹locale‹M_trivial››

end
head>

Theory Higher_Order_Constructs

section‹Fully relational versions of higher order construct ›
theory Higher_Order_Constructs
  imports
    Recursion_Thms
    Least
begin

syntax
  "_sats"  :: "[i, i, i] ⇒ o"  ("(_, _ ⊨ _)" [36,36,36] 25)
translations
  "(M,env ⊨ φ)" ⇌ "CONST sats(M,φ,env)"

definition
  is_If :: "[i⇒o,o,i,i,i] ⇒ o" where
  "is_If(M,b,t,f,r) ≡ (b ⟶ r=t) ∧ (¬b ⟶ r=f)"

lemma (in M_trans) If_abs:
  "is_If(M,b,t,f,r) ⟷ r = If(b,t,f)"
  by (simp add: is_If_def)


definition
  is_If_fm :: "[i,i,i,i] ⇒ i" where
  "is_If_fm(φ,t,f,r) ≡ Or(And(φ,Equal(t,r)),And(Neg(φ),Equal(f,r)))"

lemma is_If_fm_type [TC]: "φ ∈ formula ⟹ t ∈ nat ⟹ f ∈ nat ⟹ r ∈ nat ⟹
  is_If_fm(φ,t,f,r) ∈ formula"
  unfolding is_If_fm_def by auto

lemma sats_is_If_fm:
  assumes Qsats: "Q ⟷ A, env ⊨ φ" "env ∈ list(A)"
  shows "is_If(##A, Q, nth(t, env), nth(f, env), nth(r, env)) ⟷ A, env ⊨ is_If_fm(φ,t,f,r)"
  using assms unfolding is_If_def is_If_fm_def by auto

lemma is_If_fm_iff_sats [iff_sats]:
  assumes Qsats: "Q ⟷ A, env ⊨ φ" and
    "nth(t, env) = ta" "nth(f, env) = fa" "nth(r, env) = ra"
    "t ∈ nat" "f ∈ nat" "r ∈ nat" "env ∈ list(A)"
  shows "is_If(##A,Q,ta,fa,ra) ⟷ A, env ⊨ is_If_fm(φ,t,f,r)"
  using assms sats_is_If_fm[of Q A φ env t f r] by simp

lemma arity_is_If_fm [arity]:
  "φ ∈ formula ⟹ t ∈ nat ⟹ f ∈ nat ⟹ r ∈ nat ⟹
    arity(is_If_fm(φ, t, f, r)) = arity(φ) ∪ succ(t) ∪ succ(r) ∪ succ(f)"
  unfolding is_If_fm_def
  by auto

definition
  is_The :: "[i⇒o,i⇒o,i] ⇒ o" where
  "is_The(M,Q,i) ≡ (Q(i) ∧ (∃x[M]. Q(x) ∧ (∀y[M]. Q(y) ⟶ y = x))) ∨
                   (¬(∃x[M]. Q(x) ∧ (∀y[M]. Q(y) ⟶ y = x))) ∧ empty(M,i) "

(*
definition
  is_The_fm :: "[i,i] ⇒ i" where
  "is_The_fm(q,i) ≡ Or(And(Exists(And(Equal(succ(i),0),q)),
                  Exists(And(q,Forall(Implies(q,Equal(1,0)))))),
                          And(Neg(Exists(And(q,Forall(Implies(q,Equal(1,0)))))),empty_fm(i)))"

(* this doesn't work yet *)
lemma sats_The_fm :
  assumes p_iff_sats:
    "⋀a. a ∈ A ⟹ P(a) ⟷ sats(A, p, Cons(a, env))"
  shows
    "⟦y ∈ nat; env ∈ list(A) ; 0∈A⟧
    ⟹ sats(A, is_The_fm(p,y), env) ⟷
        is_The(##A, P, nth(y,env))"
  using nth_closed p_iff_sats
  unfolding is_The_def is_The_fm_def
  oops

lemma The_iff_sats [iff_sats]:
  assumes is_Q_iff_sats:
      "⋀a. a ∈ A ⟹ is_Q(a) ⟷ sats(A, q, Cons(a,env))"
  shows
  "⟦nth(j,env) = y; j ∈ nat; env ∈ list(A); 0∈A⟧
   ⟹ is_The(##A, is_Q, y) ⟷ sats(A, is_The_fm(q,j), env)"
  using sats_The_fm [OF is_Q_iff_sats, of j , symmetric]
  by simp
*)

lemma (in M_trans) The_abs:
  assumes "⋀x. Q(x) ⟹ M(x)" "M(a)"
  shows "is_The(M,Q,a) ⟷ a = (THE x. Q(x))"
proof (cases "∃x[M]. Q(x) ∧ (∀y[M]. Q(y) ⟶ y = x)")
  case True
  with assms
  show ?thesis
    unfolding is_The_def
    by (intro iffI the_equality[symmetric])
      (auto, blast intro:theI)
next
  case False
  with ‹⋀x. Q(x) ⟹ M(x)›
  have " ¬ (∃x. Q(x) ∧ (∀y. Q(y) ⟶ y = x))"
    by auto
  then
  have "The(Q) = 0"
    by (intro the_0) auto
  with assms and False
  show ?thesis
    unfolding is_The_def
    by auto
qed

(*
definition
  recursor  :: "[i, [i,i]=>i, i]=>i"  where
    "recursor(a,b,k) ≡  transrec(k, λn f. nat_case(a, λm. b(m, f`m), n))"
*)

definition
  is_recursor :: "[i⇒o,i,[i,i,i]⇒o,i,i] ⇒o" where
  "is_recursor(M,a,is_b,k,r) ≡ is_transrec(M, λn f ntc. is_nat_case(M,a,
      λm bmfm.
      ∃fm[M]. fun_apply(M,f,m,fm) ∧ is_b(m,fm,bmfm),n,ntc),k,r)"

lemma (in M_eclose) recursor_abs:
  assumes "Ord(k)" and
    types: "M(a)" "M(k)" "M(r)" and
    b_iff: "⋀m f bmf. M(m) ⟹ M(f) ⟹ M(bmf) ⟹ is_b(m,f,bmf)  ⟷ bmf = b(m,f)" and
    b_closed: "⋀m f bmf. M(m) ⟹ M(f) ⟹ M(b(m,f))" and
    repl: "transrec_replacement(M, λn f ntc. is_nat_case(M, a,
        λm bmfm. ∃fm[M]. fun_apply(M, f, m, fm) ∧ is_b( m, fm, bmfm), n, ntc), k)"
  shows
    "is_recursor(M,a,is_b,k,r) ⟷ r = recursor(a,b,k)"
  unfolding is_recursor_def recursor_def
  using assms
  apply (rule_tac transrec_abs)
       apply (auto simp:relation2_def)
   apply (rule nat_case_abs[THEN iffD1, where is_b1="λm bmfm.
      ∃fm[M]. fun_apply(M,_,m,fm) ∧ is_b(m,fm,bmfm)"])
      apply (auto simp:relation1_def)
  apply (rule nat_case_abs[THEN iffD2, where is_b1="λm bmfm.
      ∃fm[M]. fun_apply(M,_,m,fm) ∧ is_b(m,fm,bmfm)"])
     apply (auto simp:relation1_def)
  done

definition
  is_wfrec_on :: "[i=>o,[i,i,i]=>o,i,i,i, i] => o" where
  "is_wfrec_on(M,MH,A,r,a,z) == is_wfrec(M,MH,r,a,z)"

lemma (in M_trancl) trans_wfrec_on_abs:
  "[|wf(r);  trans(r);  relation(r);  M(r);  M(a);  M(z);
     wfrec_replacement(M,MH,r);  relation2(M,MH,H);
     ∀x[M]. ∀g[M]. function(g) ⟶ M(H(x,g));
     r-``{a}⊆A; a ∈ A|]
   ==> is_wfrec_on(M,MH,A,r,a,z) ⟷ z=wfrec[A](r,a,H)"
  using trans_wfrec_abs wfrec_trans_restr
  unfolding is_wfrec_on_def by simp

end
body>

Theory Relativization

section‹Automatic relativization of terms and formulas›

text‹Relativization of terms and formulas. Relativization of formulas shares relativized terms as
far as possible; assuming that the witnesses for the relativized terms are always unique.›

theory Relativization
  imports
    "ZF-Constructible.Datatype_absolute"
    Higher_Order_Constructs
  keywords
    "relativize" :: thy_decl % "ML"
    and
    "relativize_tm" :: thy_decl % "ML"
    and
    "reldb_add" :: thy_decl % "ML"
    and
    "reldb_rem" :: thy_decl % "ML"
    and
    "relationalize" :: thy_decl % "ML"
    and
    "rel_closed" :: thy_goal_stmt % "ML"
    and
    "is_iff_rel" :: thy_goal_stmt % "ML"
    and
    "univalent" :: thy_goal_stmt % "ML"
    and
    "absolute"
    and
    "functional"
    and
    "relational"
    and
    "external"
    and
    "for"

begin

ML_file‹Relativization_Database.ml›

ML‹
structure Absoluteness = Named_Thms
  (val name = @{binding "absolut"}
   val description = "Theorems of absoulte terms and predicates.")
›
setup‹Absoluteness.setup›

lemmas relative_abs =
  M_trans.empty_abs
  M_trans.pair_abs
  M_trivial.cartprod_abs
  M_trans.union_abs
  M_trans.inter_abs
  M_trans.setdiff_abs
  M_trans.Union_abs
  M_trivial.cons_abs
  (*M_trans.upair_abs*)
  M_trivial.successor_abs
  M_trans.Collect_abs
  M_trans.Replace_abs
  M_trivial.lambda_abs2
  M_trans.image_abs
  (*M_trans.powerset_abs*)
  M_trivial.nat_case_abs
  (*
  M_trans.transitive_set_abs
  M_trans.ordinal_abs
  M_trivial.limit_ordinal_abs
  M_trivial.successor_ordinal_abs
  M_trivial.finite_ordinal_abs
*)
  M_trivial.omega_abs
  M_basic.sum_abs
  M_trivial.Inl_abs
  M_trivial.Inr_abs
  M_basic.converse_abs
  M_basic.vimage_abs
  M_trans.domain_abs
  M_trans.range_abs
  M_basic.field_abs
  (* M_basic.apply_abs *)
  (*
  M_trivial.typed_function_abs
  M_basic.injection_abs
  M_basic.surjection_abs
  M_basic.bijection_abs
  *)
  M_basic.composition_abs
  M_trans.restriction_abs
  M_trans.Inter_abs
  M_trivial.bool_of_o_abs
  M_trivial.not_abs
  M_trivial.and_abs
  M_trivial.or_abs
  M_trivial.Nil_abs
  M_trivial.Cons_abs
  (*M_trivial.quasilist_abs*)
  M_trivial.list_case_abs
  M_trivial.hd_abs
  M_trivial.tl_abs
  M_trivial.least_abs'
  M_eclose.transrec_abs
  M_trans.If_abs
  M_trans.The_abs
  M_eclose.recursor_abs
  M_trancl.trans_wfrec_abs
  M_trancl.trans_wfrec_on_abs

lemmas datatype_abs =
  M_datatypes.list_N_abs
  M_datatypes.list_abs
  M_datatypes.formula_N_abs
  M_datatypes.formula_abs
  M_eclose.is_eclose_n_abs
  M_eclose.eclose_abs
  M_datatypes.length_abs
  M_datatypes.nth_abs
  M_trivial.Member_abs
  M_trivial.Equal_abs
  M_trivial.Nand_abs
  M_trivial.Forall_abs
  M_datatypes.depth_abs
  M_datatypes.formula_case_abs

declare relative_abs[absolut]
declare datatype_abs[absolut]

ML‹
signature Relativization =
  sig
    structure Data: GENERIC_DATA
    val Rel_add: attribute
    val Rel_del: attribute
    val add_rel_const : Database.mode -> term -> term -> Data.T -> Data.T
    val add_constant : Database.mode -> string -> string -> Proof.context -> Proof.context
    val rem_constant : (term -> Data.T -> Data.T) -> string -> Proof.context -> Proof.context
    val db: Data.T
    val init_db : Data.T -> theory -> theory
    val get_db : Proof.context -> Data.T
    val relativ_fm: bool -> bool -> term -> Data.T -> (term * (term * term)) list * Proof.context * term list * bool -> term -> term * ((term * (term * term)) list * term list * term list * Proof.context)
    val relativ_tm: bool -> bool -> term option -> term -> Data.T -> (term * (term * term)) list * Proof.context -> term -> term * (term * (term * term)) list * Proof.context
    val read_new_const : Proof.context -> string -> term
    val relativ_tm_frm': bool -> bool -> term -> Data.T -> Proof.context -> term -> term option * term
    val relativize_def: bool -> bool -> bool -> bstring -> string -> Position.T -> Proof.context -> Proof.context
    val relativize_tm: bool -> bstring -> string -> Position.T -> Proof.context -> Proof.context
    val rel_closed_goal : string -> Position.T -> Proof.context -> Proof.state
    val iff_goal : string -> Position.T -> Proof.context -> Proof.state
    val univalent_goal : string -> Position.T -> Proof.context -> Proof.state
  end

structure Relativization : Relativization = struct

infix 6 &&&
val op &&& = Utils.&&&

infix 6 ***
val op *** = Utils.***

infix 6 @@
val op @@ = Utils.@@

infix 6 ---
val op --- = Utils.---

fun insert_abs2rel ((t, u), db) = ((t, u), Database.insert Database.abs2rel (t, t) db)

fun insert_rel2is ((t, u), db) = Database.insert Database.rel2is (t, u) db

(* relativization db of relation constructors *)
val db = [ (@{const relation}, @{const Relative.is_relation})
         , (@{const function}, @{const Relative.is_function})
         , (@{const mem}, @{const mem})
         , (@{const True}, @{const True})
         , (@{const False}, @{const False})
         , (@{const Memrel}, @{const membership})
         , (@{const trancl}, @{const tran_closure})
         , (@{const IFOL.eq(i)}, @{const IFOL.eq(i)})
         , (@{const Subset}, @{const Relative.subset})
         , (@{const quasinat}, @{const Relative.is_quasinat})
         , (@{const apply}, @{const Relative.fun_apply})
         , (@{const Upair}, @{const Relative.upair})
         ]
         |> List.foldr (insert_rel2is o insert_abs2rel) Database.empty
         |> Database.insert Database.abs2is (@{const Pi}, @{const is_funspace})

fun var_i v = Free (v, @{typ i})
fun var_io v = Free (v, @{typ "i ⇒ o"})
val const_name = #1 o dest_Const

val lookup_tm  = AList.lookup (op aconv)
val update_tm  =  AList.update (op aconv)
val join_tm = AList.join (op aconv) (K #1)

val conj_ = Utils.binop @{const "IFOL.conj"}

(* generic data *)
structure Data = Generic_Data
(
  type T = Database.db
  val empty = Database.empty (* Should we initialize this outside this file? *)
  val merge = Database.merge
);

fun init_db db = Context.theory_map (Data.put db)

fun get_db thy = Data.get (Context.Proof thy)

val read_const = Proof_Context.read_const {proper = true, strict = true}
val read_new_const = Proof_Context.read_term_pattern

fun add_rel_const mode c t = Database.insert mode (c, t)

fun get_consts thm =
  let val (c_rel, rhs) = Thm.concl_of thm |> Utils.dest_trueprop |>
                          Utils.dest_iff_tms |>> head_of
  in case try Utils.dest_eq_tms rhs of
       SOME tm => (c_rel, tm |> #2 |> head_of)
     | NONE => (c_rel, rhs |> Utils.dest_mem_tms |> #2 |> head_of)
  end

fun add_rule thm rs =
  let val (c_rel,c_abs) = get_consts thm
  (* in (add_rel_const Database.rel2is c_abs c_rel o add_rel_const Database.abs2rel c_abs c_abs) rs *)
  in (add_rel_const Database.abs2rel c_abs c_abs o add_rel_const Database.abs2is c_abs c_rel) rs
end

fun get_mode is_functional relationalising = if relationalising then Database.rel2is else if is_functional then Database.abs2rel else Database.abs2is

fun add_constant mode abs rel thy =
  let
    val c_abs = read_new_const thy abs
    val c_rel = read_new_const thy rel
    val db_map = Data.map (Database.insert mode (c_abs, c_rel))
    fun add_to_context ctxt' = Context.proof_map db_map ctxt'
    fun add_to_theory ctxt' = Local_Theory.raw_theory (Context.theory_map db_map) ctxt'
  in
    Local_Theory.target (add_to_theory o add_to_context) thy
 end

fun rem_constant rem_op c thy =
  let
    val c = read_new_const thy c
    val db_map = Data.map (rem_op c)
    fun add_to_context ctxt' = Context.proof_map db_map ctxt'
    fun add_to_theory ctxt' = Local_Theory.raw_theory (Context.theory_map db_map) ctxt'
  in
    Local_Theory.target (add_to_theory o add_to_context) thy
  end

val del_rel_const = Database.remove_abs

fun del_rule thm = del_rel_const (thm |> get_consts |> #2)

val Rel_add =
  Thm.declaration_attribute (fn thm => fn context =>
    Data.map (add_rule (Thm.trim_context thm)) context);

val Rel_del =
  Thm.declaration_attribute (fn thm => fn context =>
    Data.map (del_rule (Thm.trim_context thm)) context);

(* Conjunction of a list of terms *)
fun conjs [] = @{term IFOL.True}
  | conjs (fs as _ :: _) = foldr1 (uncurry conj_) fs

(* Produces a relativized existential quantification of the term t *)
fun rex p t (Free v) = @{const rex} $ p $ lambda (Free v) t
  | rex _ t (Bound _) = t
  | rex _ t tm = raise TERM ("rex shouldn't handle this.",[tm,t])

(* Constants that do not take the class predicate *)
val absolute_rels = [ @{const ZF_Base.mem}
                    , @{const IFOL.eq(i)}
                    , @{const Memrel}
                    , @{const True}
                    , @{const False}
                    ]

(* Creates the relational term corresponding to a term of type i. If the last
  argument is (SOME v) then that variable is not bound by an existential
  quantifier.
*)
fun close_rel_tm pred tm tm_var rs =
  let val news = filter (not o (fn x => is_Free x orelse is_Bound x) o #1) rs
      val (vars, tms) = split_list (map #2 news) ||> (curry op @) (the_list tm)
      val vars = case tm_var of
        SOME w => filter (fn v => not (v = w)) vars
      | NONE => vars
  in fold (fn v => fn t => rex pred (incr_boundvars 1 t) v) vars (conjs tms)
  end

fun relativ_tms __ _ _ rs ctxt [] = ([], rs, ctxt)
  | relativ_tms is_functional relationalising pred rel_db rs ctxt (u :: us) =
      let val (w_u, rs_u, ctxt_u) = relativ_tm is_functional relationalising NONE pred rel_db (rs, ctxt) u
          val (w_us, rs_us, ctxt_us) = relativ_tms is_functional relationalising pred rel_db rs_u ctxt_u us
      in (w_u :: w_us, join_tm (rs_u , rs_us), ctxt_us)
      end
and
    (* The result of the relativization of a term is a triple consisting of
      a. the relativized term (it can be a free or a bound variable but also a Collect)
      b. a list of (term * (term, term)), taken as a map, which is used
         to reuse relativization of different occurrences of the same term. The
         first element is the original term, the second its relativized version,
         and the last one is the predicate corresponding to it.
      c. the resulting context of created variables.
    *)
    relativ_tm is_functional relationalising mv pred rel_db (rs,ctxt) tm =
      let
      (* relativization of a fully applied constant *)
      fun mk_rel_const mv c (args, after) abs_args ctxt =
        case Database.lookup (get_mode is_functional relationalising) c rel_db of
          SOME p =>
            let
              val args' = List.filter (not o member (op =) (Utils.frees p)) args
              val (v, ctxt1) =
                the_default
                  (Variable.variant_fixes [""] ctxt |>> var_i o hd)
                  (Utils.map_option (I &&& K ctxt) mv)
              val args' =
                (* FIXME: This special case for functional relativization of sigma should not be needed *)
                if c = @{const Sigma} andalso is_functional
                  then
                    let
                      val t = hd args'
                      val t' = Abs ("uu_", @{typ "i"}, (hd o tl) args' |> incr_boundvars 1)
                    in
                      [t, t']
                    end
                  else
                    args'
              val arg_list = if after then abs_args @ args' else args' @ abs_args
              val r_tm =
                if is_functional
                  then list_comb (p, if p = c then arg_list else pred :: arg_list)
                  else list_comb (p, if (not o null) args' andalso  hd args' = pred then arg_list @ [v] else pred :: arg_list @ [v])
            in
              if is_functional
                then (r_tm, r_tm, ctxt)
                else (v, r_tm, ctxt1)
            end
        | NONE => raise TERM ("Constant " ^ const_name c ^ " is not present in the db." , nil)
      (* relativization of a partially applied constant *)
      fun relativ_app mv mctxt tm abs_args (Const c) (args, after) rs =
            let
              val (w_ts, rs_ts, ctxt_ts) = relativ_tms is_functional relationalising pred rel_db rs (the_default ctxt mctxt) args
              val (w_tm, r_tm, ctxt_tm) = mk_rel_const mv (Const c) (w_ts, after) abs_args ctxt_ts
              val rs_ts' = if is_functional then rs_ts else update_tm (tm, (w_tm, r_tm)) rs_ts
            in
              (w_tm, rs_ts', ctxt_tm)
            end
        | relativ_app _ _ _ _ t _ _ =
            raise TERM ("Tried to relativize an application with a non-constant in head position",[t])

      (* relativization of non dependent product and sum *)
      fun relativ_app_no_dep mv tm c t t' rs =
          if loose_bvar1 (t', 0)
            then
              raise TERM("A dependency was found when trying to relativize", [tm])
            else
              relativ_app mv NONE tm [] c ([t, incr_boundvars ~1 t'], false) rs

      fun relativ_replace mv t body after ctxt' =
        let
          val (v, b) = Utils.dest_abs body |>> var_i ||> after
          val (b', (rs', ctxt'')) =
            relativ_fm is_functional relationalising pred rel_db (rs, ctxt', single v, false) b |>> incr_boundvars 1 ||> #1 &&& #4
        in
          relativ_app mv (SOME ctxt'') tm [lambda v b'] @{const Replace} ([t], false) rs'
        end

      fun get_abs_body (Abs body) = body
        | get_abs_body t = raise TERM ("Term is not Abs", [t])

      fun go _ (Var _) = raise TERM ("Var: Is this possible?",[])
        | go mv (@{const Replace} $ t $ Abs body) = relativ_replace mv t body I ctxt
        (* It is easier to rewrite RepFun as Replace before relativizing,
           since { f(x) . x ∈ t } = { y . x ∈ t, y = f(x) } *)
        | go mv (@{const RepFun} $ t $ Abs body) =
            let
              val (y, ctxt') = Variable.variant_fixes [""] ctxt |>> var_i o hd
            in
              relativ_replace mv t body (lambda y o Utils.eq_ y o incr_boundvars 1) ctxt'
            end
        | go mv (@{const Collect} $ t $ pc) =
            let
              val (pc', (rs', ctxt')) = relativ_fm is_functional relationalising pred rel_db (rs,ctxt, [], false) pc ||> #1 &&& #4
            in
              relativ_app mv (SOME ctxt') tm [pc'] @{const Collect} ([t], false) rs'
            end
        | go mv (@{const Least} $ pc) =
            let
              val (pc', (rs', ctxt')) = relativ_fm is_functional relationalising pred rel_db (rs,ctxt, [], false) pc ||> #1 &&& #4
            in
              relativ_app mv (SOME ctxt') tm [pc'] @{const Least} ([], false) rs'
            end
        | go mv (@{const transrec} $ t $ Abs body) =
            let
              val (res, ctxt') = Variable.variant_fixes [if is_functional then "_aux" else ""] ctxt |>> var_i o hd
              val (x, b') = Utils.dest_abs body |>> var_i
              val (y, b) = get_abs_body b' |> Utils.dest_abs |>> var_i
              val p = Utils.eq_ res b |> lambda res
              val (p', (rs', ctxt'')) = relativ_fm is_functional relationalising pred rel_db (rs, ctxt', [x, y], true) p |>> incr_boundvars 3 ||> #1 &&& #4
              val p' = if is_functional then p' |> #2 o Utils.dest_eq_tms o #2 o Utils.dest_abs o get_abs_body else p'
            in
              relativ_app mv (SOME ctxt'') tm [p' |> lambda x o lambda y] @{const transrec} ([t], not is_functional) rs'
            end
        | go mv (tm as @{const Sigma} $ t $ Abs (_, _, t')) =
            relativ_app_no_dep mv tm @{const Sigma} t t' rs
        | go mv (tm as @{const Pi} $ t $ Abs (_, _, t')) =
            relativ_app_no_dep mv tm @{const Pi} t t' rs
        | go mv (tm as @{const bool_of_o} $ t) =
            let
              val (t', (rs', ctxt')) = relativ_fm is_functional relationalising pred rel_db (rs, ctxt, [], false) t ||> #1 &&& #4
            in
              relativ_app mv (SOME ctxt') tm [t'] @{const bool_of_o} ([], false) rs'
            end
        | go mv (tm as @{const If} $ b $ t $ t') =
            let
              val (br, (rs', ctxt')) = relativ_fm is_functional relationalising pred rel_db (rs, ctxt, [], false) b ||> #1 &&& #4
            in
              relativ_app mv (SOME ctxt') tm [br] @{const If} ([t,t'], true) rs'
            end
        | go mv (@{const The} $ pc) =
            let
              val (pc', (rs', ctxt')) = relativ_fm is_functional relationalising pred rel_db (rs,ctxt, [], false) pc ||> #1 &&& #4
            in
              relativ_app mv (SOME ctxt') tm [pc'] @{const The} ([], false) rs'
            end
        | go mv (@{const recursor} $ t $ Abs body $ t') =
            let
              val (res, ctxt') = Variable.variant_fixes [if is_functional then "_aux" else ""] ctxt |>> var_i o hd
              val (x, b') = Utils.dest_abs body |>> var_i
              val (y, b) = get_abs_body b' |> Utils.dest_abs |>> var_i
              val p = Utils.eq_ res b |> lambda res
              val (p', (rs', ctxt'')) = relativ_fm is_functional relationalising pred rel_db (rs, ctxt', [x, y], true) p |>> incr_boundvars 3 ||> #1 &&& #4
              val p' = if is_functional then p' |> #2 o Utils.dest_eq_tms o #2 o Utils.dest_abs o get_abs_body else p'
              val (tr, rs'', ctxt''') = relativ_tm is_functional relationalising NONE pred rel_db (rs', ctxt'') t
            in
              relativ_app mv (SOME ctxt''') tm [tr, p' |> lambda x o lambda y] @{const recursor} ([t'], true) rs''
            end
        | go mv (@{const wfrec} $ t1 $ t2 $ Abs body) =
            let
              val (res, ctxt') = Variable.variant_fixes [if is_functional then "_aux" else ""] ctxt |>> var_i o hd
              val (x, b') = Utils.dest_abs body |>> var_i
              val (y, b) = get_abs_body b' |> Utils.dest_abs |>> var_i
              val p = Utils.eq_ res b |> lambda res
              val (p', (rs', ctxt'')) = relativ_fm is_functional relationalising pred rel_db (rs, ctxt', [x, y], true) p |>> incr_boundvars 3 ||> #1 &&& #4
              val p' = if is_functional then p' |> #2 o Utils.dest_eq_tms o #2 o Utils.dest_abs o get_abs_body else p'
            in
              relativ_app mv (SOME ctxt'') tm [p' |> lambda x o lambda y] @{const wfrec} ([t1,t2], not is_functional) rs'
            end
        | go mv (@{const wfrec_on} $ t1 $ t2 $ t3 $ Abs body) =
            let
              val (res, ctxt') = Variable.variant_fixes [if is_functional then "_aux" else ""] ctxt |>> var_i o hd
              val (x, b') = Utils.dest_abs body |>> var_i
              val (y, b) = get_abs_body b' |> Utils.dest_abs |>> var_i
              val p = Utils.eq_ res b |> lambda res
              val (p', (rs', ctxt'')) = relativ_fm is_functional relationalising pred rel_db (rs, ctxt', [x, y], true) p |>> incr_boundvars 3 ||> #1 &&& #4
              val p' = if is_functional then p' |> #2 o Utils.dest_eq_tms o #2 o Utils.dest_abs o get_abs_body else p'
            in
              relativ_app mv (SOME ctxt'') tm [p' |> lambda x o lambda y] @{const wfrec_on} ([t1,t2,t3], not is_functional) rs'
            end
        | go mv (@{const Lambda} $ t $ Abs body) =
            let
              val (res, ctxt') = Variable.variant_fixes [if is_functional then "_aux" else ""] ctxt |>> var_i o hd
              val (x, b) = Utils.dest_abs body |>> var_i
              val p = Utils.eq_ res b |> lambda res
              val (p', (rs', ctxt'')) = relativ_fm is_functional relationalising pred rel_db (rs, ctxt', [x], true) p |>> incr_boundvars 2 ||> #1 &&& #4
              val p' = if is_functional then p' |> #2 o Utils.dest_eq_tms o #2 o Utils.dest_abs o get_abs_body else p'
              val (tr, rs'', ctxt''') = relativ_tm is_functional relationalising NONE pred rel_db (rs', ctxt'') t
            in
              relativ_app mv (SOME ctxt''') tm [tr, p' |> lambda x] @{const Lambda} ([], true) rs''
            end
        (* The following are the generic cases *)
        | go mv (tm as Const _) = relativ_app mv NONE tm [] tm ([], false) rs
        | go mv (tm as _ $ _) = (strip_comb tm ||> I &&& K false |> uncurry (relativ_app mv NONE tm [])) rs
        | go _ tm = if is_functional then (tm, rs, ctxt) else (tm, update_tm (tm,(tm,tm)) rs, ctxt)

      (* we first check if the term has been already relativized as a variable *)
      in case lookup_tm rs tm of
           NONE => go mv tm
         | SOME (w, _) => (w, rs, ctxt)
      end
and
  relativ_fm is_functional relationalising pred rel_db (rs, ctxt, vs, is_term) fm =
  let

  (* relativization of a fully applied constant *)
  fun relativ_app (ctxt, rs) c args = case Database.lookup (get_mode is_functional relationalising) c rel_db of
    SOME p =>
      let (* flag indicates whether the relativized constant is absolute or not. *)
        val flag = not (exists (curry op aconv c) absolute_rels orelse c = p)
        val (args, rs_ts, ctxt') = relativ_tms is_functional relationalising pred rel_db rs ctxt args
        (* TODO: Verify if next line takes care of locales' definitions *)
        val args' = List.filter (not o member (op =) (Utils.frees p)) args
        val args'' = if not (null args') andalso hd args' = pred then args' else pred :: args'
        val tm = list_comb (p, if flag then args'' else args')
        (* TODO: Verify if next line is necessary *)
        val news = filter (not o (fn x => is_Free x orelse is_Bound x) o #1) rs_ts
        val (vars, tms) = split_list (map #2 news)
        (* val vars = filter (fn v => not (v = tm)) vars *) (* Verify if this line is necessary *)
       in (tm, (rs_ts, vars, tms, ctxt'))
       end
   | NONE   => raise TERM ("Constant " ^ const_name c ^ " is not present in the db." , nil)

  fun close_fm quantifier (f, (rs, vars, tms, ctxt)) =
    let
      fun contains_b0 t = loose_bvar1 (t, 0)

      fun contains_extra_var t = fold (fn v => fn acc => acc orelse fold_aterms (fn t => fn acc => t = v orelse acc) t false) vs false

      fun contains_b0_extra t = contains_b0 t orelse contains_extra_var t

      (* t1 $ v ↪ t2 iff v ∈ FV(t2) *)
      fun chained_frees (_ $ v) t2 = member (op =) (Utils.frees t2) v
        | chained_frees t _ = raise TERM ("Malformed term", [t])

      val tms_to_close = filter contains_b0_extra tms |> Utils.reachable chained_frees tms
      val tms_to_keep = map (incr_boundvars ~1) (tms --- tms_to_close)
      val vars_to_close = inter (op =) (map (List.last o #2 o strip_comb) tms_to_close) vars
      val vars_to_keep = vars --- vars_to_close
      val new_rs =
        rs
        |> filter (fn (k, (v, rel)) => not (contains_b0_extra k orelse contains_b0_extra v orelse contains_b0_extra rel))
        |> map (fn (k, (v, rel)) => (incr_boundvars ~1 k, (incr_boundvars ~1 v, incr_boundvars ~1 rel)))

      val f' =
        if not is_term andalso not quantifier andalso is_functional
          then pred $ Bound 0 :: (map (curry (op $) pred) vs) @ [f]
          else [f]
    in
      (fold (fn v => fn t => rex pred (incr_boundvars 1 t) v) vars_to_close (conjs (f' @ tms_to_close)),
       (new_rs, vars_to_keep, tms_to_keep, ctxt))
    end

  (* Handling of bounded quantifiers. *)
  fun bquant (ctxt, rs) quant conn dom pred =
    let val (v,pred') = Utils.dest_abs pred |>> var_i
    in
      go (ctxt, rs, false) (quant $ (lambda v o incr_boundvars 1) (conn $ (@{const mem} $ v $ dom) $ pred'))
    end
  and
  bind_go (ctxt, rs) const f f' =
    let
      val (r , (rs1, vars1, tms1, ctxt1)) = go (ctxt, rs, false) f
      val (r', (rs2, vars2, tms2, ctxt2)) = go (ctxt1, rs1, false) f'
    in
      (const $ r $ r', (rs2, vars1 @@ vars2, tms1 @@ tms2, ctxt2))
    end
  and
      relativ_eq_var (ctxt, rs) v t =
        let
          val (_, rs', ctxt') = relativ_tm is_functional relationalising (SOME v) pred rel_db (rs, ctxt) t
          val f = lookup_tm rs' t |> #2 o the
          val rs'' = filter (not o (curry (op =) t) o #1) rs'
          val news = filter (not o (fn x => is_Free x orelse is_Bound x) o #1) rs''
          val (vars, tms) = split_list (map #2 news)
        in
          (f, (rs'', vars, tms, ctxt'))
        end
  and
      relativ_eq (ctxt, rs) t1 t2 =
        if is_functional orelse ((is_Free t1 orelse is_Bound t1) andalso (is_Free t2 orelse is_Bound t2)) then
          relativ_app (ctxt, rs) @{const IFOL.eq(i)} [t1, t2]
        else if is_Free t1 orelse is_Bound t1 then
          relativ_eq_var (ctxt, rs) t1 t2
        else if is_Free t2 orelse is_Bound t2 then
          relativ_eq_var (ctxt, rs) t2 t1
        else
          relativ_app (ctxt, rs) @{const IFOL.eq(i)} [t1, t2]
  and
      go (ctxt, rs, _         ) (@{const IFOL.conj} $ f $ f') = bind_go (ctxt, rs) @{const IFOL.conj} f f'
    | go (ctxt, rs, _         ) (@{const IFOL.disj} $ f $ f') = bind_go (ctxt, rs) @{const IFOL.disj} f f'
    | go (ctxt, rs, _         ) (@{const IFOL.Not} $ f) = go (ctxt, rs, false) f |>> ((curry op $) @{const IFOL.Not})
    | go (ctxt, rs, _         ) (@{const IFOL.iff} $ f $ f') = bind_go (ctxt, rs) @{const IFOL.iff} f f'
    | go (ctxt, rs, _         ) (@{const IFOL.imp} $ f $ f') = bind_go (ctxt, rs) @{const IFOL.imp} f f'
    | go (ctxt, rs, _         ) (@{const IFOL.All(i)} $ f) = go (ctxt, rs, true) f |>> ((curry op $) (@{const OrdQuant.rall} $ pred))
    | go (ctxt, rs, _         ) (@{const IFOL.Ex(i)} $ f) = go (ctxt, rs, true) f |>> ((curry op $) (@{const OrdQuant.rex} $ pred))
    | go (ctxt, rs, _         ) (@{const Bex} $ f $ Abs p) = bquant (ctxt, rs) @{const Ex(i)} @{const IFOL.conj} f p
    | go (ctxt, rs, _         ) (@{const Ball} $ f $ Abs p) = bquant (ctxt, rs) @{const All(i)} @{const IFOL.imp} f p
    | go (ctxt, rs, _         ) (@{const rall} $ _ $ p) = go (ctxt, rs, true) p |>> (curry op $) (@{const rall} $ pred)
    | go (ctxt, rs, _         ) (@{const rex} $ _ $ p) = go (ctxt, rs, true) p |>> (curry op $) (@{const rex} $ pred)
    | go (ctxt, rs, _         ) (@{const IFOL.eq(i)} $ t1 $ t2) = relativ_eq (ctxt, rs) t1 t2
    | go (ctxt, rs, _         ) (Const c) = relativ_app (ctxt, rs) (Const c) []
    | go (ctxt, rs, _         ) (tm as _ $ _) = strip_comb tm |> uncurry (relativ_app (ctxt, rs))
    | go (ctxt, rs, quantifier) (Abs (v, _, t)) =
      let
        val new_rs = map (fn (k, (v, rel)) => (incr_boundvars 1 k, (incr_boundvars 1 v, incr_boundvars 1 rel))) rs
      in
        go (ctxt, new_rs, false) t |> close_fm quantifier |>> lambda (var_i v)
      end
    | go _ t = raise TERM ("Relativization of formulas cannot handle this case.",[t])
  in
    go (ctxt, rs, false) fm
  end


fun relativ_tm_frm' is_functional relationalising cls_pred db ctxt tm =
  let
    fun get_bounds (l as Abs _) = op @@ (strip_abs l |>> map (op #1) ||> get_bounds)
      | get_bounds (t as _$_) = strip_comb t |> op :: |> map get_bounds |> flat
      | get_bounds _ = []

    val ty = fastype_of tm
    val initial_ctxt = fold Utils.add_to_context (get_bounds tm) ctxt
  in
    case ty of
        @{typ i} =>
          let
            val (w, rs, _) =  relativ_tm is_functional relationalising NONE cls_pred db ([], initial_ctxt) tm
          in
            if is_functional
              then (NONE, w)
              else (SOME w, close_rel_tm cls_pred NONE (SOME w) rs)
          end
      | @{typ o} =>
          let
            fun close_fm (f, (_, vars, tms, _)) =
              fold (fn  v => fn t => rex cls_pred (incr_boundvars 1 t) v) vars (conjs (f :: tms))
          in
            (NONE, relativ_fm is_functional relationalising cls_pred db ([], initial_ctxt, [], false) tm |> close_fm)
          end
      | ty' => raise TYPE ("We can relativize only terms of types i and o", [ty'], [tm])
  end

fun lname ctxt = Local_Theory.full_name ctxt o Binding.name

fun destroy_first_lambdas (Abs (body as (_, ty, _))) =
     Utils.dest_abs body ||> destroy_first_lambdas |> (#1 o #2) &&& ((fn v => Free (v, ty)) *** #2) ||> op ::
  | destroy_first_lambdas t = (t, [])

fun freeType (Free (_, ty)) = ty
  | freeType t = raise TERM ("freeType", [t])

fun relativize_def is_external is_functional relationalising def_name thm_ref pos lthy =
  let
    val ctxt = lthy
    val (vars,tm,ctxt1) = Utils.thm_concl_tm ctxt (thm_ref ^ "_def")
    val db' = Data.get (Context.Proof lthy)
    val (tm, lambdavars) = tm |> destroy_first_lambdas o #2 o Utils.dest_eq_tms' o Utils.dest_trueprop
    val ctxt1 = fold Utils.add_to_context (map Utils.freeName lambdavars) ctxt1
    val (cls_pred, ctxt1, vars, lambdavars) =
      if (not o null) vars andalso (#2 o #1 o hd) vars = @{typ "i ⇒ o"} then
        ((Thm.term_of o #2 o hd) vars, ctxt1, tl vars, lambdavars)
      else if null vars andalso (not o null) lambdavars andalso (freeType o hd) lambdavars = @{typ "i ⇒ o"} then
        (hd lambdavars, ctxt1, vars, tl lambdavars)
      else Variable.variant_fixes ["N"] ctxt1 |>> var_io o hd |> (fn (cls, ctxt) => (cls, ctxt, vars, lambdavars))
    val db' = db' |> Database.insert Database.abs2rel (cls_pred, cls_pred)
                     o Database.insert Database.rel2is (cls_pred, cls_pred)
    val (v,t) = relativ_tm_frm' is_functional relationalising cls_pred db' ctxt1 tm
    val t_vars = sort_strings (Term.add_free_names tm [])
    val vs' = List.filter (#1 #> #1 #> #1 #> Ord_List.member String.compare t_vars) vars
    val vs = cls_pred :: map (Thm.term_of o #2) vs' @ lambdavars @ the_list v
    val at = List.foldr (uncurry lambda) t vs
    val abs_const = read_const lthy (if is_external then thm_ref else lname lthy thm_ref)
    fun new_const ctxt' = read_new_const ctxt' def_name
    fun db_map ctxt' =
       Data.map (add_rel_const (get_mode is_functional relationalising) abs_const (new_const ctxt'))
    fun add_to_context ctxt' = Context.proof_map (db_map ctxt') ctxt'
    fun add_to_theory ctxt' = Local_Theory.raw_theory (Context.theory_map (db_map ctxt')) ctxt'
  in
    lthy
    |> Local_Theory.define ((Binding.name def_name, NoSyn), ((Binding.name (def_name ^ "_def"), []), at))
    |>> (#2 #> (fn (s,t) => (s,[t])))
    |> Utils.display "theorem" pos
    |> Local_Theory.target (add_to_theory o add_to_context)
  end

fun relativize_tm is_functional def_name term pos lthy =
  let
    val ctxt = lthy
    val (cls_pred, ctxt1) = Variable.variant_fixes ["N"] ctxt |>> var_io o hd
    val tm = Syntax.read_term ctxt1 term
    val db' = Data.get (Context.Proof lthy)
    val db' = db' |> Database.insert Database.abs2rel (cls_pred, cls_pred)
                     o Database.insert Database.rel2is (cls_pred, cls_pred)
    val vs' = Variable.add_frees ctxt1 tm []
    val ctxt2 = fold Utils.add_to_context (map #1 vs') ctxt1
    val (v,t) = relativ_tm_frm' is_functional false cls_pred db' ctxt2 tm
    val vs = cls_pred :: map Free vs' @ the_list v
    val at = List.foldr (uncurry lambda) t vs
  in
    lthy
    |> Local_Theory.define ((Binding.name def_name, NoSyn), ((Binding.name (def_name ^ "_def"), []), at))
    |>> (#2 #> (fn (s,t) => (s,[t])))
    |> Utils.display "theorem" pos
  end

val op $` = curry ((op $) o swap)
infix $`

fun is_free_i (Free (_, @{typ "i"})) = true
  | is_free_i _ = false

fun rel_closed_goal target pos lthy =
  let
    val (_, tm, _) = Utils.thm_concl_tm lthy (target ^ "_rel_def")
    val (def, tm) = tm |> Utils.dest_eq_tms'
    fun first_lambdas (Abs (body as (_, ty, _))) =
        if ty = @{typ "i"}
          then (op ::) (Utils.dest_abs body |>> Utils.var_i ||> first_lambdas)
          else Utils.dest_abs body |> first_lambdas o #2
      | first_lambdas _ = []
    val (def, vars) = Term.strip_comb def ||> filter is_free_i
    val vs = vars @ first_lambdas tm
    val class = Free ("M", @{typ "i ⇒ o"})
    val def = fold (op $`) (class :: vs) def
    val hyps = map (fn v => class $ v |> Utils.tp) vs
    val concl = class $ def
    val goal = Logic.list_implies (hyps, Utils.tp concl)
    val attribs = @{attributes [intro, simp]}
  in
    Proof.theorem NONE (fn thmss => Utils.display "theorem" pos
                                    o Local_Theory.note ((Binding.name (target ^ "_rel_closed"), attribs), hd thmss))
    [[(goal, [])]] lthy
  end

fun iff_goal target pos lthy =
  let
    val (_, tm, ctxt') = Utils.thm_concl_tm lthy (target ^ "_rel_def")
    val (_, is_def, ctxt) = Utils.thm_concl_tm ctxt' ("is_" ^ target ^ "_def")
    val is_def = is_def |> Utils.dest_eq_tms' |> #1 |> Term.strip_comb |> #1
    val (def, tm) = tm |> Utils.dest_eq_tms'
    fun first_lambdas (Abs (body as (_, ty, _))) =
        if ty = @{typ "i"}
          then (op ::) (Utils.dest_abs body |>> Utils.var_i ||> first_lambdas)
          else Utils.dest_abs body |> first_lambdas o #2
      | first_lambdas _ = []
    val (def, vars) = Term.strip_comb def ||> filter is_free_i
    val vs = vars @ first_lambdas tm
    val class = Free ("M", @{typ "i ⇒ o"})
    val def = fold (op $`) (class :: vs) def
    val ty = fastype_of def
    val res = if ty = @{typ "i"}
                then Variable.variant_fixes ["res"] ctxt |> SOME o Utils.var_i o hd o #1
                else NONE
    val is_def = fold (op $`) (class :: vs @ the_list res) is_def
    val hyps = map (fn v => class $ v |> Utils.tp) (vs @ the_list res)
    val concl = @{const "IFOL.iff"} $ is_def
              $ (if ty = @{typ "i"} then (@{const IFOL.eq(i)} $ the res $ def) else def)
    val goal = Logic.list_implies (hyps, Utils.tp concl)
  in
    Proof.theorem NONE (fn thmss => Utils.display "theorem" pos
                                    o Local_Theory.note ((Binding.name ("is_" ^ target ^ "_iff"), []), hd thmss))
    [[(goal, [])]] lthy
  end

fun univalent_goal target pos lthy =
  let
    val (_, tm, ctxt) = Utils.thm_concl_tm lthy ("is_" ^ target ^ "_def")
    val (def, tm) = tm |> Utils.dest_eq_tms'
    fun first_lambdas (Abs (body as (_, ty, _))) =
        if ty = @{typ "i"}
          then (op ::) (Utils.dest_abs body |>> Utils.var_i ||> first_lambdas)
          else Utils.dest_abs body |> first_lambdas o #2
      | first_lambdas _ = []
    val (def, vars) = Term.strip_comb def ||> filter is_free_i
    val vs = vars @ first_lambdas tm
    val n = length vs
    val vs = List.take (vs, n - 2)
    val class = Free ("M", @{typ "i ⇒ o"})
    val def = fold (op $`) (class :: vs) def
    val v = Variable.variant_fixes ["A"] ctxt |> Utils.var_i o hd o #1
    val hyps = map (fn v => class $ v |> Utils.tp) (v :: vs)
    val concl = @{const "Relative.univalent"} $ class $ v $ def
    val goal = Logic.list_implies (hyps, Utils.tp concl)
  in
    Proof.theorem NONE (fn thmss => Utils.display "theorem" pos
                                    o Local_Theory.note ((Binding.name ("univalent_is_" ^ target), []), hd thmss))
    [[(goal, [])]] lthy
  end

end
›

ML‹
local
  val full_mode_parser =
       Scan.option (((Parse.$$$ "functional" |-- Parse.$$$ "relational") >> K Database.rel2is)
                    || (((Scan.option (Parse.$$$ "absolute")) |-- Parse.$$$ "functional") >> K Database.abs2rel)
                    || (((Scan.option (Parse.$$$ "absolute")) |-- Parse.$$$ "relational") >> K Database.abs2is))
       >> (fn mode => the_default Database.abs2is mode)

  val reldb_parser =
       Parse.position (full_mode_parser -- (Parse.string -- Parse.string));

  val singlemode_parser = (Parse.$$$ "absolute" >> K Database.remove_abs)
                       || (Parse.$$$ "functional" >> K Database.remove_rel)
                       || (Parse.$$$ "relational" >> K Database.remove_is)

  val reldb_rem_parser = Parse.position (singlemode_parser -- Parse.string)

  val mode_parser =
       Scan.option ((Parse.$$$ "relational" >> K false) || (Parse.$$$ "functional" >> K true))
       >> (fn mode => if is_none mode then false else the mode)

  val relativize_parser =
       Parse.position (mode_parser -- (Parse.string -- Parse.string) -- (Scan.optional (Parse.$$$ "external" >> K true) false));

  val _ =
     Outer_Syntax.local_theory command_keyword‹reldb_add› "ML setup for adding relativized/absolute pairs"
       (reldb_parser >> (fn ((mode, (abs_term,rel_term)),_) =>
          Relativization.add_constant mode abs_term rel_term))

  val _ =
   Outer_Syntax.local_theory command_keyword‹reldb_rem› "ML setup for adding relativized/absolute pairs"
     (reldb_rem_parser >> (uncurry Relativization.rem_constant o #1))

  val _ =
     Outer_Syntax.local_theory command_keyword‹relativize› "ML setup for relativizing definitions"
       (relativize_parser >> (fn (((is_functional, (bndg,thm)), is_external),pos) =>
          Relativization.relativize_def is_external is_functional false thm bndg pos))

  val _ =
     Outer_Syntax.local_theory command_keyword‹relativize_tm› "ML setup for relativizing definitions"
       (relativize_parser >> (fn (((is_functional, (bndg,term)), _),pos) =>
          Relativization.relativize_tm is_functional term bndg pos))

  val _ =
     Outer_Syntax.local_theory command_keyword‹relationalize› "ML setup for relativizing definitions"
       (relativize_parser >> (fn (((is_functional, (bndg,thm)), is_external),pos) =>
          Relativization.relativize_def is_external is_functional true thm bndg pos))

  val _ =
    Outer_Syntax.local_theory_to_proof command_keyword‹rel_closed› "ML setup for rel_closed theorem"
      (Parse.position (Parse.$$$ "for" |-- Parse.string) >> (fn (target,pos) =>
        Relativization.rel_closed_goal target pos))

  val _ =
    Outer_Syntax.local_theory_to_proof command_keyword‹is_iff_rel› "ML setup for rel_closed theorem"
      (Parse.position (Parse.$$$ "for" |-- Parse.string) >> (fn (target,pos) =>
        Relativization.iff_goal target pos))

  val _ =
    Outer_Syntax.local_theory_to_proof command_keyword‹univalent› "ML setup for rel_closed theorem"
      (Parse.position (Parse.$$$ "for" |-- Parse.string) >> (fn (target,pos) =>
        Relativization.univalent_goal target pos))

val _ =
  Theory.setup
   (Attrib.setup binding‹Rel› (Attrib.add_del Relativization.Rel_add Relativization.Rel_del)
      "declaration of relativization rule") ;
in
end
›
setup‹Relativization.init_db Relativization.db ›

declare relative_abs[Rel]
  (*todo: check all the duplicate cases here.*)
declare datatype_abs[Rel]

ML‹
val db = Relativization.get_db @{context}
›

end
tle>

File ‹Relativization_Database.ml›

signature Database =
  sig
    type db
    val empty : db
    type mode
    val abs2is : mode
    val abs2rel : mode
    val rel2is : mode
    val lookup : mode -> term -> db -> term option
    val insert : mode -> term * term -> db -> db
    val remove_abs : term -> db -> db
    val remove_rel : term -> db -> db
    val remove_is : term -> db -> db
    val merge : db * db -> db

    (* INVARIANTS *)
    (* ∀ db : db, ∀ t, t' : term, ∀ m : mode, lookup m t db = lookup m t' db ≠ NONE ⟹ t = t' *)
    (* ∀ db : db, ∀ t, u, v : term, lookup abs2rel t db = SOME v ∧ lookup rel2is v db = SOME u ⟹ lookup abs2is t db = SOME u *)
    (* ∀ db : db, ∀ t, u, v : term, lookup abs2is t db = SOME u ∧ lookup rel2is v db = SOME u ⟹ lookup abs2rel t db = SOME v *)
    (* ∀ db : db, ∀ t, u, v : term, lookup abs2rel t db = SOME u ∧ lookup abs2is t db = SOME v ⟹ lookup rel2is u db = SOME v *)
  end

structure Database : Database = struct
  type db = { ar : (term * term) list
            , af : (term * term) list
            , fr : (term * term) list
            }

  val empty = { ar = []
              , af = []
              , fr = []
              }

  datatype singlemode = Absolute | Relational | Functional

  type mode = singlemode * singlemode

  val abs2is = (Absolute, Relational)

  val abs2rel = (Absolute, Functional)

  val rel2is = (Functional, Relational)

  infix 6 &&&
  val op &&& = Utils.&&&

  infix 5 |||
  fun op ||| (x, y) = fn t =>
    case x t of
      SOME a => SOME a
    | NONE => y t

  infix 5 >>=
  fun op >>= (m, f) =
    case m of
      SOME x => f x
    | NONE => NONE

  infix 6 COMP
  fun op COMP (xs, ys) = fn t => AList.lookup (op aconv) ys t >>= AList.lookup (op aconv) xs

  val transpose = map (#2 &&& #1)

  fun lookup (Absolute, Relational) t db = (#fr db COMP #af db ||| AList.lookup (op aconv) (#ar db)) t
    | lookup (Absolute, Functional) t db = AList.lookup (op aconv) (#af db) t
    | lookup (Functional, Relational) t db = AList.lookup (op aconv) (#fr db) t
    | lookup (Relational, Absolute) t db = (transpose (#af db) COMP transpose (#fr db) ||| AList.lookup (op aconv) (transpose (#ar db))) t
    | lookup (Functional, Absolute) t db = AList.lookup (op aconv) (transpose (#af db)) t
    | lookup (Relational, Functional) t db = AList.lookup (op aconv) (transpose (#fr db)) t
    | lookup _ _ _ = error "lookup: unreachable clause"

  fun insert' warn (mode as (Absolute, Relational)) (t, u) db =
      (case lookup mode t db of
        SOME _ => (warn ("insert abs2is: duplicate entry for " ^ (@{make_string} t)); db)
      | NONE => case lookup (Relational, Functional) u db of
                  SOME v => if is_none (lookup (Functional, Absolute) v db)
                              then { ar = #ar db
                                   , af = AList.update (op aconv) (t, v) (#af db)
                                   , fr = #fr db
                                   }
                              else error "invariant violation, insert abs2is"
                | NONE => case lookup (Absolute, Functional) t db of
                            SOME v => { ar = #ar db
                                      , af = #af db
                                      , fr = AList.update (op aconv) (v, u) (#fr db)
                                      }
                          | NONE => { ar = AList.update (op aconv) (t, u) (#ar db)
                                    , af = #af db
                                    , fr = #fr db
                                    }
      )
    | insert' warn (mode as (Absolute, Functional)) (t, v) db =
      (case lookup mode t db of
        SOME _ => (warn ("insert abs2rel: duplicate entry for " ^ (@{make_string} t)); db)
      | NONE => case lookup (Functional, Relational) v db of
                  SOME u => (case lookup (Relational, Absolute) u db of
                              NONE => { ar = #ar db
                                      , af = AList.update (op aconv) (t, v) (#af db)
                                      , fr = #fr db
                                      }
                            | SOME t' => if t = t'
                                           then { ar = AList.delete (op aconv) t (#ar db)
                                                , af = AList.update (op aconv) (t, v) (#af db)
                                                , fr = #fr db
                                                }
                                           else error "invariant violation, insert abs2rel"
                            )
                | NONE => case lookup (Absolute, Relational) t db of
                            SOME u => { ar = AList.delete (op aconv) t (#ar db)
                                      , af = AList.update (op aconv) (t, v) (#af db)
                                      , fr = AList.update (op aconv) (v, u) (#fr db)
                                      }
                          | NONE => { ar = #ar db
                                    , af = AList.update (op aconv) (t, v) (#af db)
                                    , fr = #fr db
                                    }
      )
    | insert' warn (mode as (Functional, Relational)) (v, u) db =
      (case lookup mode v db of
        SOME _ => (warn ("insert rel2is: duplicate entry for " ^ (@{make_string} v)); db)
      | NONE => case (lookup (Functional, Absolute) v db, lookup (Relational, Absolute) u db) of
                  (SOME t, SOME t') => if t = t'
                                         then { ar = AList.delete (op aconv) t (#ar db)
                                              , af = #af db
                                              , fr = AList.update (op aconv) (v, u) (#fr db)
                                              }
                                         else error ("invariant violation, insert rel2is: " ^ (@{make_string} (v, u, t, t')))
                | (SOME _, NONE) => { ar = #ar db
                                    , af = #af db
                                    , fr = AList.update (op aconv) (v, u) (#fr db)
                                    }
                | (NONE, SOME t') => { ar = AList.delete (op aconv) t' (#ar db)
                                     , af = AList.update (op aconv) (t', v) (#af db)
                                     , fr = AList.update (op aconv) (v, u) (#fr db)
                                     }
                | (NONE, NONE) => { ar = #ar db
                                  , af = #af db
                                  , fr = AList.update (op aconv) (v, u) (#fr db)
                                  }
      )
    | insert' _ _ _ _ = error "insert: unreachable clause"

  val insert = insert' warning

  fun remove Absolute t db = { ar = AList.delete (op aconv) t (#ar db)
                             , af = AList.delete (op aconv) t (#af db)
                             , fr = #fr db
                             }
    | remove Functional v db =
      (case lookup (Functional, Absolute) v db of
        SOME t => (case lookup (Functional, Relational) v db of
                    SOME u => { ar = AList.update (op aconv) (t, u) (#ar db)
                              , af = transpose (AList.delete (op aconv) v (transpose (#af db)))
                              , fr = AList.delete (op aconv) v (#fr db)
                              }
                  | NONE => { ar = #ar db
                            , af = transpose (AList.delete (op aconv) v (transpose (#af db)))
                            , fr = #fr db
                            }
                  )
      | NONE => { ar = #ar db
                , af = #af db
                , fr = AList.delete (op aconv) v (#fr db)
                }
      )
    | remove Relational u db = { ar = transpose (AList.delete (op aconv) u (transpose (#ar db)))
                               , af = #af db
                               , fr = transpose (AList.delete (op aconv) u (transpose (#fr db)))
                               }

  val remove_abs = remove Absolute

  val remove_rel = remove Functional

  val remove_is = remove Relational

  fun merge (db, db') =
    let
      val modes = [(abs2rel, #af db'), (rel2is, #fr db'), (abs2is, #ar db)]
    in
      List.foldr (fn ((m, db'), db) => List.foldr (uncurry (insert' (K ())  m)) db db') db modes
    end
end (* structure Database : Database *)

Theory Discipline_Base

theory Discipline_Base
  imports
    "ZF-Constructible.Rank"
    ZF_Miscellanea
    M_Basic_No_Repl
    Relativization

begin

declare [[syntax_ambiguity_warning = false]]

subsection‹Discipline of relativization of basic concepts›

definition
  is_singleton :: "[i⇒o,i,i] ⇒ o" where
  "is_singleton(A,x,z) ≡ ∃c[A]. empty(A,c) ∧ is_cons(A,x,c,z)"

lemma (in M_trivial) singleton_abs[simp] :
  "⟦ M(x) ; M(s) ⟧ ⟹ is_singleton(M,x,s) ⟷ s = {x}"
  unfolding is_singleton_def using nonempty by simp

synthesize "singleton" from_definition "is_singleton"
notation singleton_fm (‹⋅{_} is _⋅›)

(* TODO: check if the following lemmas should be here or not? *)
lemma (in M_trivial) singleton_closed [simp]:
  "M(x) ⟹ M({x})"
  by simp

lemma (in M_trivial) Upair_closed[simp]: "M(a) ⟹ M(b) ⟹ M(Upair(a,b))"
  using Upair_eq_cons by simp


text‹The following named theorems gather instances of transitivity
that arise from closure theorems›
named_theorems trans_closed

definition
  is_hcomp :: "[i⇒o,i⇒i⇒o,i⇒i⇒o,i,i] ⇒ o" where
  "is_hcomp(M,is_f,is_g,a,w) ≡ ∃z[M]. is_g(a,z) ∧ is_f(z,w)"

lemma (in M_trivial) is_hcomp_abs:
  assumes
    is_f_abs:"⋀a z. M(a) ⟹ M(z) ⟹ is_f(a,z) ⟷ z = f(a)" and
    is_g_abs:"⋀a z. M(a) ⟹ M(z) ⟹ is_g(a,z) ⟷ z = g(a)" and
    g_closed:"⋀a. M(a) ⟹ M(g(a))"
    "M(a)" "M(w)"
  shows
    "is_hcomp(M,is_f,is_g,a,w) ⟷ w = f(g(a))"
  unfolding is_hcomp_def using assms by simp

definition
  hcomp_fm :: "[i⇒i⇒i,i⇒i⇒i,i,i] ⇒ i" where
  "hcomp_fm(pf,pg,a,w) ≡ Exists(And(pg(succ(a),0),pf(0,succ(w))))"

lemma sats_hcomp_fm:
  assumes
    f_iff_sats:"⋀a b z. a∈nat ⟹ b∈nat ⟹ z∈M ⟹
                 is_f(nth(a,Cons(z,env)),nth(b,Cons(z,env))) ⟷ sats(M,pf(a,b),Cons(z,env))"
    and
    g_iff_sats:"⋀a b z. a∈nat ⟹ b∈nat ⟹ z∈M ⟹
                is_g(nth(a,Cons(z,env)),nth(b,Cons(z,env))) ⟷ sats(M,pg(a,b),Cons(z,env))"
    and
    "a∈nat" "w∈nat" "env∈list(M)"
  shows
    "sats(M,hcomp_fm(pf,pg,a,w),env) ⟷ is_hcomp(##M,is_f,is_g,nth(a,env),nth(w,env))"
proof -
  have "sats(M, pf(0, succ(w)), Cons(x, env)) ⟷ is_f(x,nth(w,env))" if "x∈M" "w∈nat" for x w
    using f_iff_sats[of 0 "succ(w)" x] that by simp
  moreover
  have "sats(M, pg(succ(a), 0), Cons(x, env)) ⟷ is_g(nth(a,env),x)" if "x∈M" "a∈nat" for x a
    using g_iff_sats[of "succ(a)" 0 x] that by simp
  ultimately
  show ?thesis unfolding hcomp_fm_def is_hcomp_def using assms by simp
qed


definition
  hcomp_r :: "[i⇒o,[i⇒o,i,i]⇒o,[i⇒o,i,i]⇒o,i,i] ⇒ o" where
  "hcomp_r(M,is_f,is_g,a,w) ≡ ∃z[M]. is_g(M,a,z) ∧ is_f(M,z,w)"

definition
  is_hcomp2_2 :: "[i⇒o,[i⇒o,i,i,i]⇒o,[i⇒o,i,i,i]⇒o,[i⇒o,i,i,i]⇒o,i,i,i] ⇒ o" where
  "is_hcomp2_2(M,is_f,is_g1,is_g2,a,b,w) ≡ ∃g1ab[M]. ∃g2ab[M].
       is_g1(M,a,b,g1ab) ∧ is_g2(M,a,b,g2ab) ∧ is_f(M,g1ab,g2ab,w)"

lemma (in M_trivial) hcomp_abs:
  assumes
    is_f_abs:"⋀a z. M(a) ⟹ M(z) ⟹ is_f(M,a,z) ⟷ z = f(a)" and
    is_g_abs:"⋀a z. M(a) ⟹ M(z) ⟹ is_g(M,a,z) ⟷ z = g(a)" and
    g_closed:"⋀a. M(a) ⟹ M(g(a))"
    "M(a)" "M(w)"
  shows
    "hcomp_r(M,is_f,is_g,a,w) ⟷ w = f(g(a))"
  unfolding hcomp_r_def using assms by simp

lemma hcomp_uniqueness:
  assumes
    uniq_is_f:
    "⋀r d d'. M(r) ⟹ M(d) ⟹ M(d') ⟹ is_f(M, r, d) ⟹ is_f(M, r, d') ⟹
               d = d'"
    and
    uniq_is_g:
    "⋀r d d'. M(r) ⟹ M(d) ⟹ M(d') ⟹ is_g(M, r, d) ⟹ is_g(M, r, d') ⟹
               d = d'"
    and
    "M(a)" "M(w)" "M(w')"
    "hcomp_r(M,is_f,is_g,a,w)"
    "hcomp_r(M,is_f,is_g,a,w')"
  shows
    "w=w'"
proof -
  from assms
  obtain z z' where "is_g(M, a, z)" "is_g(M, a, z')"
    "is_f(M,z,w)" "is_f(M,z',w')"
    "M(z)" "M(z')"
    unfolding hcomp_r_def by blast
  moreover from this and uniq_is_g and ‹M(a)›
  have "z=z'" by blast
  moreover note uniq_is_f and ‹M(w)› ‹M(w')›
  ultimately
  show ?thesis by blast
qed

lemma hcomp_witness:
  assumes
    wit_is_f: "⋀r. M(r) ⟹ ∃d[M]. is_f(M,r,d)" and
    wit_is_g: "⋀r. M(r) ⟹ ∃d[M]. is_g(M,r,d)" and
    "M(a)"
  shows
    "∃w[M]. hcomp_r(M,is_f,is_g,a,w)"
proof -
  from ‹M(a)› and wit_is_g
  obtain z where "is_g(M,a,z)" "M(z)" by blast
  moreover from this and wit_is_f
  obtain w where "is_f(M,z,w)" "M(w)" by blast
  ultimately
  show ?thesis
    using assms unfolding hcomp_r_def by auto
qed

lemma (in M_trivial) hcomp2_2_abs:
  assumes
    is_f_abs:"⋀r1 r2 z. M(r1) ⟹ M(r2) ⟹  M(z) ⟹ is_f(M,r1,r2,z) ⟷ z = f(r1,r2)" and
    is_g1_abs:"⋀r1 r2 z. M(r1) ⟹ M(r2) ⟹  M(z) ⟹ is_g1(M,r1,r2,z) ⟷ z = g1(r1,r2)" and
    is_g2_abs:"⋀r1 r2 z. M(r1) ⟹ M(r2) ⟹  M(z) ⟹ is_g2(M,r1,r2,z) ⟷ z = g2(r1,r2)" and
    types: "M(a)" "M(b)" "M(w)" "M(g1(a,b))" "M(g2(a,b))"
  shows
    "is_hcomp2_2(M,is_f,is_g1,is_g2,a,b,w) ⟷ w = f(g1(a,b),g2(a,b))"
  unfolding is_hcomp2_2_def using assms
    ― ‹We only need some particular cases of the abs assumptions›
    (* is_f_abs types is_g1_abs[of a b] is_g2_abs[of a b] *)
  by simp

lemma hcomp2_2_uniqueness:
  assumes
    uniq_is_f:
    "⋀r1 r2 d d'. M(r1) ⟹ M(r2) ⟹ M(d) ⟹ M(d') ⟹
        is_f(M, r1, r2 , d) ⟹ is_f(M, r1, r2, d') ⟹  d = d'"
    and
    uniq_is_g1:
    "⋀r1 r2 d d'. M(r1) ⟹ M(r2)⟹ M(d) ⟹ M(d') ⟹ is_g1(M, r1,r2, d) ⟹ is_g1(M, r1,r2, d') ⟹
               d = d'"
    and
    uniq_is_g2:
    "⋀r1 r2 d d'. M(r1) ⟹ M(r2)⟹ M(d) ⟹ M(d') ⟹ is_g2(M, r1,r2, d) ⟹ is_g2(M, r1,r2, d') ⟹
               d = d'"
    and
    "M(a)" "M(b)" "M(w)" "M(w')"
    "is_hcomp2_2(M,is_f,is_g1,is_g2,a,b,w)"
    "is_hcomp2_2(M,is_f,is_g1,is_g2,a,b,w')"
  shows
    "w=w'"
proof -
  from assms
  obtain z z' y y' where "is_g1(M, a,b, z)" "is_g1(M, a,b, z')"
    "is_g2(M, a,b, y)" "is_g2(M, a,b, y')"
    "is_f(M,z,y,w)" "is_f(M,z',y',w')"
    "M(z)" "M(z')" "M(y)" "M(y')"
    unfolding is_hcomp2_2_def by force
  moreover from this and uniq_is_g1 uniq_is_g2 and ‹M(a)› ‹M(b)›
  have "z=z'" "y=y'" by blast+
  moreover note uniq_is_f and ‹M(w)› ‹M(w')›
  ultimately
  show ?thesis by blast
qed

lemma hcomp2_2_witness:
  assumes
    wit_is_f: "⋀r1 r2. M(r1) ⟹ M(r2) ⟹ ∃d[M]. is_f(M,r1,r2,d)" and
    wit_is_g1: "⋀r1 r2. M(r1) ⟹ M(r2) ⟹ ∃d[M]. is_g1(M,r1,r2,d)" and
    wit_is_g2: "⋀r1 r2. M(r1) ⟹ M(r2) ⟹ ∃d[M]. is_g2(M,r1,r2,d)" and
    "M(a)" "M(b)"
  shows
    "∃w[M]. is_hcomp2_2(M,is_f,is_g1,is_g2,a,b,w)"
proof -
  from ‹M(a)› ‹M(b)› and wit_is_g1
  obtain g1a where "is_g1(M,a,b,g1a)" "M(g1a)" by blast
  moreover from ‹M(a)› ‹M(b)› and wit_is_g2
  obtain g2a where "is_g2(M,a,b,g2a)" "M(g2a)" by blast
  moreover from calculation and wit_is_f
  obtain w where "is_f(M,g1a,g2a,w)" "M(w)" by blast
  ultimately
  show ?thesis
    using assms unfolding is_hcomp2_2_def by auto
qed

lemma (in M_trivial) extensionality_trans:
  assumes
    "M(d) ∧ (∀x[M]. x∈d  ⟷ P(x))"
    "M(d') ∧ (∀x[M]. x∈d' ⟷ P(x))"
  shows
    "d=d'"
proof -
  from assms
  have "∀x. x∈d ⟷ P(x) ∧ M(x)"
    using transM[of _ d] by auto
  moreover from assms
  have  "∀x. x∈d' ⟷ P(x) ∧ M(x)"
    using transM[of _ d'] by auto
  ultimately
  show ?thesis by auto
qed

definition
  lt_rel :: "[i⇒o,i,i] ⇒ o" where
  "lt_rel(M,a,b) ≡ a∈b ∧ ordinal(M,b)"

lemma (in M_trans) lt_abs[absolut]: "M(a) ⟹ M(b) ⟹ lt_rel(M,a,b) ⟷ a<b"
  unfolding lt_rel_def lt_def by auto

definition
  le_rel :: "[i⇒o,i,i] ⇒ o" where
  "le_rel(M,a,b) ≡ ∃sb[M]. successor(M,b,sb) ∧ lt_rel(M,a,sb)"

lemma (in M_trivial) le_abs[absolut]: "M(a) ⟹ M(b) ⟹ le_rel(M,a,b) ⟷ a≤b"
  unfolding le_rel_def by (simp add:absolut)

subsection‹Discipline for term‹Pow››

definition
  is_Pow :: "[i⇒o,i,i] ⇒ o" where
  "is_Pow(M,A,z) ≡ M(z) ∧ (∀x[M]. x ∈ z ⟷ subset(M,x,A))"

definition
  Pow_rel :: "[i⇒o,i] ⇒ i" (‹Pow⇗_⇖'(_')›) where
  "Pow_rel(M,r) ≡ THE d. is_Pow(M,r,d)"

abbreviation
  Pow_r_set ::  "[i,i] ⇒ i" (‹Pow⇗_⇖'(_')›) where
  "Pow_r_set(M) ≡ Pow_rel(##M)"

context M_basic_no_repl
begin

lemma is_Pow_uniqueness:
  assumes
    "M(r)"
    "is_Pow(M,r,d)" "is_Pow(M,r,d')"
  shows
    "d=d'"
  using assms extensionality_trans
  unfolding is_Pow_def
  by simp

lemma is_Pow_witness: "M(r) ⟹ ∃d[M]. is_Pow(M,r,d)"
  using power_ax unfolding power_ax_def powerset_def is_Pow_def
  by simp ― ‹We have to do this by hand, using axioms›

lemma is_Pow_closed : "⟦ M(r);is_Pow(M,r,d) ⟧ ⟹ M(d)"
  unfolding is_Pow_def by simp

lemma Pow_rel_closed[intro,simp]: "M(r) ⟹ M(Pow_rel(M,r))"
  unfolding Pow_rel_def
  using is_Pow_closed theI[OF ex1I[of "λd. is_Pow(M,r,d)"], OF _ is_Pow_uniqueness[of r]]
    is_Pow_witness
  by fastforce

lemmas trans_Pow_rel_closed[trans_closed] = transM[OF _ Pow_rel_closed]

text‹The proof of term‹f_rel_iff› lemma is schematic and it can reused by copy-paste
     replacing appropriately.›

lemma Pow_rel_iff:
  assumes "M(r)"  "M(d)"
  shows "is_Pow(M,r,d) ⟷ d = Pow_rel(M,r)"
proof (intro iffI)
  assume "d = Pow_rel(M,r)"
  with assms
  show "is_Pow(M, r, d)"
    using is_Pow_uniqueness[of r] is_Pow_witness
      theI[OF ex1I[of "λd. is_Pow(M,r,d)"], OF _ is_Pow_uniqueness[of r]]
    unfolding Pow_rel_def
    by auto
next
  assume "is_Pow(M, r, d)"
  with assms
  show "d = Pow_rel(M,r)"
    using is_Pow_uniqueness unfolding Pow_rel_def
    by (auto del:the_equality intro:the_equality[symmetric])
qed

text‹The next "def\_" result really corresponds to @{thm Pow_iff}›
lemma def_Pow_rel: "M(A) ⟹ M(r) ⟹ A∈Pow_rel(M,r) ⟷ A ⊆ r"
  using Pow_rel_iff[OF _ Pow_rel_closed, of r r]
  unfolding is_Pow_def by simp

lemma Pow_rel_char: "M(r) ⟹ Pow_rel(M,r) = {A∈Pow(r). M(A)}"
proof -
  assume "M(r)"
  moreover from this
  have "x ∈ Pow_rel(M,r) ⟹ x⊆r" "M(x) ⟹ x ⊆ r ⟹ x ∈ Pow_rel(M,r)" for x
    using def_Pow_rel by (auto intro!:trans_Pow_rel_closed)
  ultimately
  show ?thesis
    using trans_Pow_rel_closed by blast
qed

lemma mem_Pow_rel_abs: "M(a) ⟹ M(r) ⟹ a ∈ Pow_rel(M,r) ⟷ a ∈ Pow(r)"
  using Pow_rel_char by simp

end ― ‹locale‹M_basic_no_repl››

(******************  end Discipline  **********************)


(**********************************************************)
subsection‹Discipline for term‹PiP››

definition
  PiP_rel:: "[i⇒o,i,i]⇒o" where
  "PiP_rel(M,A,f) ≡ ∃df[M]. is_domain(M,f,df) ∧ subset(M,A,df) ∧
                             is_function(M,f)"

context M_basic
begin

lemma def_PiP_rel:
  assumes
    "M(A)" "M(f)"
  shows
    "PiP_rel(M,A,f) ⟷ A ⊆ domain(f) ∧ function(f)"
  using assms unfolding PiP_rel_def by simp

end ― ‹locale‹M_basic››

(******************  end Discipline  **********************)

(*
Sigma(A,B) == ⋃x∈A. ⋃y∈B(x). {⟨x,y⟩}
           == ⋃ {  (⋃y∈B(x). {⟨x,y⟩})  . x∈A}
           == ⋃ {  (⋃y∈B(x). {⟨x,y⟩})  . x∈A}
           == ⋃ {  ( ⋃ { {⟨x,y⟩} . y∈B(x)} )  . x∈A}
                     ----------------------
                           Sigfun(x,B)
*)

definition ― ‹FIX THIS: not completely relational. Can it be?›
  Sigfun :: "[i,i⇒i]⇒i"  where
  "Sigfun(x,B) ≡ ⋃y∈B(x). {⟨x,y⟩}"

lemma Sigma_Sigfun: "Sigma(A,B) = ⋃ {Sigfun(x,B) . x∈A}"
  unfolding Sigma_def Sigfun_def ..

definition ― ‹FIX THIS: not completely relational. Can it be?›
  is_Sigfun :: "[i⇒o,i,i⇒i,i]⇒o"  where
  "is_Sigfun(M,x,B,Sd) ≡ M(Sd) ∧ (∃RB[M]. is_Replace(M,B(x),λy z. z={⟨x,y⟩},RB)
                         ∧ big_union(M,RB,Sd))"


context M_trivial
begin

lemma is_Sigfun_abs:
  assumes
    "strong_replacement(M,λy z. z={⟨x,y⟩})"
    "M(x)" "M(B(x))" "M(Sd)"
  shows
    "is_Sigfun(M,x,B,Sd) ⟷ Sd = Sigfun(x,B)"
proof -
  have "⋃{z . y ∈ B(x), z = {⟨x, y⟩}} = (⋃y∈B(x). {⟨x, y⟩})" by auto
  then
  show ?thesis
    using assms transM[OF _ ‹M(B(x))›] Replace_abs
    unfolding is_Sigfun_def Sigfun_def by auto
qed

lemma Sigfun_closed:
  assumes
    "strong_replacement(M, λy z. y ∈ B(x) ∧ z = {⟨x, y⟩})"
    "M(x)" "M(B(x))"
  shows
    "M(Sigfun(x,B))"
  using assms transM[OF _ ‹M(B(x))›] RepFun_closed2
  unfolding Sigfun_def by simp

lemmas trans_Sigfun_closed[trans_closed] = transM[OF _ Sigfun_closed]

end ― ‹locale‹M_trivial››

definition
  is_Sigma :: "[i⇒o,i,i⇒i,i]⇒o"  where
  "is_Sigma(M,A,B,S) ≡ M(S) ∧ (∃RSf[M].
      is_Replace(M,A,λx z. z=Sigfun(x,B),RSf) ∧ big_union(M,RSf,S))"

locale M_Pi = M_basic +
  assumes
    Pi_separation: "M(A) ⟹ separation(M, PiP_rel(M,A))"
    and
    Pi_replacement:
    "M(x) ⟹ M(y) ⟹
      strong_replacement(M, λya z. ya ∈ y ∧ z = {⟨x, ya⟩})"
    "M(y) ⟹
      strong_replacement(M, λx z. z = (⋃xa∈y. {⟨x, xa⟩}))"

locale M_Pi_assumptions = M_Pi +
  fixes A B
  assumes
    Pi_assumptions:
    "M(A)"
    "⋀x. x∈A ⟹  M(B(x))"
    "∀x∈A. strong_replacement(M, λy z. y ∈ B(x) ∧ z = {⟨x, y⟩})"
    "strong_replacement(M,λx z. z=Sigfun(x,B))"
begin

lemma Sigma_abs[simp]:
  assumes
    "M(S)"
  shows
    "is_Sigma(M,A,B,S) ⟷ S = Sigma(A,B)"
proof -
  have "⋃{z . x ∈ A, z = Sigfun(x, B)} = (⋃x∈A. Sigfun(x, B))"
    by auto
  with assms
  show ?thesis
    using Replace_abs[of A _ "λx z. z=Sigfun(x,B)"]
      Sigfun_closed Sigma_Sigfun[of A B] transM[of _ A]
      Pi_assumptions is_Sigfun_abs
    unfolding is_Sigma_def by simp
qed

lemma Sigma_closed[intro,simp]: "M(Sigma(A,B))"
proof -
  have "(⋃x∈A. Sigfun(x, B)) = ⋃{z . x ∈ A, z = Sigfun(x, B)}"
    by auto
  then
  show ?thesis
    using Sigma_Sigfun[of A B] transM[of _ A]
      Sigfun_closed Pi_assumptions
    by simp
qed

lemmas trans_Sigma_closed[trans_closed] = transM[OF _ Sigma_closed]

end ― ‹locale‹M_Pi_assumptions››

(**********************************************************)
subsection‹Discipline for term‹Pi››

definition (* completely relational *)
  is_Pi :: "[i⇒o,i,i⇒i,i]⇒o"  where
  "is_Pi(M,A,B,I) ≡ M(I) ∧ (∃S[M]. ∃PS[M]. is_Sigma(M,A,B,S) ∧
       is_Pow(M,S,PS) ∧
       is_Collect(M,PS,PiP_rel(M,A),I))"

definition
  Pi_rel :: "[i⇒o,i,i⇒i] ⇒ i"  (‹Pi⇗_⇖'(_,_')›) where
  "Pi_rel(M,A,B) ≡ THE d. is_Pi(M,A,B,d)"

abbreviation
  Pi_r_set ::  "[i,i,i⇒i] ⇒ i" (‹Pi⇗_⇖'(_,_')›) where
  "Pi_r_set(M,A,B) ≡ Pi_rel(##M,A,B)"


context M_basic
begin

lemmas Pow_rel_iff = mbnr.Pow_rel_iff
lemmas Pow_rel_char = mbnr.Pow_rel_char
lemmas mem_Pow_rel_abs = mbnr.mem_Pow_rel_abs
lemmas Pow_rel_closed = mbnr.Pow_rel_closed
lemmas def_Pow_rel = mbnr.def_Pow_rel
lemmas trans_Pow_rel_closed = mbnr.trans_Pow_rel_closed

end ― ‹locale‹M_basic››

context M_Pi_assumptions
begin

lemma is_Pi_uniqueness:
  assumes
    "is_Pi(M,A,B,d)" "is_Pi(M,A,B,d')"
  shows
    "d=d'"
  using assms Pi_assumptions extensionality_trans
    Pow_rel_iff
  unfolding is_Pi_def by simp


lemma is_Pi_witness: "∃d[M]. is_Pi(M,A,B,d)"
  using Pow_rel_iff Pi_separation Pi_assumptions
  unfolding is_Pi_def by simp

lemma is_Pi_closed : "is_Pi(M,A,B,d) ⟹ M(d)"
  unfolding is_Pi_def by simp

lemma Pi_rel_closed[intro,simp]:  "M(Pi_rel(M,A,B))"
proof -
  have "is_Pi(M, A, B, THE xa. is_Pi(M, A, B, xa))"
    using Pi_assumptions
      theI[OF ex1I[of "is_Pi(M,A,B)"], OF _ is_Pi_uniqueness]
      is_Pi_witness is_Pi_closed
    by auto
  then show ?thesis
    using is_Pi_closed
    unfolding Pi_rel_def
    by simp
qed

― ‹From this point on, the higher order variable term‹y› must be
explicitly instantiated, and proof methods are slower›

lemmas trans_Pi_rel_closed[trans_closed] = transM[OF _ Pi_rel_closed]

lemma Pi_rel_iff:
  assumes "M(d)"
  shows "is_Pi(M,A,B,d) ⟷ d = Pi_rel(M,A,B)"
proof (intro iffI)
  assume "d = Pi_rel(M,A,B)"
  moreover
  note assms
  moreover from this
  obtain e where "M(e)" "is_Pi(M,A,B,e)"
    using is_Pi_witness by blast
  ultimately
  show "is_Pi(M, A, B, d)"
    using is_Pi_uniqueness is_Pi_witness is_Pi_closed
      theI[OF ex1I[of "is_Pi(M,A,B)"], OF _ is_Pi_uniqueness, of e]
    unfolding Pi_rel_def
    by simp
next
  assume "is_Pi(M, A, B, d)"
  with assms
  show "d = Pi_rel(M,A,B)"
    using is_Pi_uniqueness is_Pi_closed unfolding Pi_rel_def
    by (blast del:the_equality intro:the_equality[symmetric])
qed

lemma def_Pi_rel:
  "Pi_rel(M,A,B) = {f∈Pow_rel(M,Sigma(A,B)). A⊆domain(f) ∧ function(f)}"
proof -
  have "Pi_rel(M,A, B) ⊆ Pow_rel(M,Sigma(A,B))"
    using Pi_assumptions Pi_rel_iff[of "Pi_rel(M,A,B)"] Pow_rel_iff
    unfolding is_Pi_def by auto
  moreover
  have "f ∈ Pi_rel(M,A, B) ⟹ A⊆domain(f) ∧ function(f)" for f
    using Pi_assumptions Pi_rel_iff[of "Pi_rel(M,A,B)"]
      def_PiP_rel[of A f] trans_closed Pow_rel_iff
    unfolding is_Pi_def by simp
  moreover
  have "f ∈ Pow_rel(M,Sigma(A,B)) ⟹ A⊆domain(f) ∧ function(f) ⟹ f ∈ Pi_rel(M,A, B)" for f
    using Pi_rel_iff[of "Pi_rel(M,A,B)"] Pi_assumptions
      def_PiP_rel[of A f] trans_closed Pow_rel_iff
    unfolding is_Pi_def by simp
  ultimately
  show ?thesis by force
qed

lemma Pi_rel_char: "Pi_rel(M,A,B) = {f∈Pi(A,B). M(f)}"
  using Pi_assumptions def_Pi_rel Pow_rel_char[OF Sigma_closed] unfolding Pi_def
  by fastforce

lemma mem_Pi_rel_abs:
  assumes "M(f)"
  shows  "f ∈ Pi_rel(M,A,B) ⟷ f ∈ Pi(A,B)"
  using assms Pi_rel_char by simp

end ― ‹locale‹M_Pi_assumptions››

text‹The next locale (and similar ones below) are used to
show the relationship between versions of simple (i.e.
$\Sigma_1^{\mathit{ZF}}$, $\Pi_1^{\mathit{ZF}}$) concepts in two
different transitive models.›
locale M_N_Pi_assumptions = M:M_Pi_assumptions + N:M_Pi_assumptions N for N +
  assumes
    M_imp_N:"M(x) ⟹ N(x)"
begin

lemma Pi_rel_transfer: "Pi⇗M⇖(A,B) ⊆ Pi⇗N⇖(A,B)"
  using  M.Pi_rel_char N.Pi_rel_char M_imp_N by auto

end ― ‹locale‹M_N_Pi_assumptions››


(******************  end Discipline  **********************)

locale M_Pi_assumptions_0 = M_Pi_assumptions _ 0
begin

text‹This is used in the proof of term‹AC_Pi_rel››
lemma Pi_rel_empty1[simp]: "Pi⇗M⇖(0,B) = {0}"
  using Pi_assumptions Pow_rel_char
  by (unfold def_Pi_rel function_def) (auto)

end ― ‹locale‹M_Pi_assumptions_0››

context M_Pi_assumptions
begin

subsection‹Auxiliary ported results on term‹Pi_rel›, now unused›
lemma Pi_rel_iff':
  assumes types:"M(f)"
  shows
    "f ∈ Pi_rel(M,A,B) ⟷ function(f) ∧ f ⊆ Sigma(A,B) ∧ A ⊆ domain(f)"
  using assms Pow_rel_char
  by (simp add:def_Pi_rel, blast)


lemma lam_type_M:
  assumes "M(A)" "⋀x. x∈A ⟹  M(B(x))"
    "⋀x. x ∈ A ⟹ b(x)∈B(x)" "strong_replacement(M,λx y. y=⟨x, b(x)⟩) "
  shows "(λx∈A. b(x)) ∈ Pi_rel(M,A,B)"
proof (auto simp add: lam_def def_Pi_rel function_def)
  from assms
  have "M({⟨x, b(x)⟩ . x ∈ A})"
    using Pi_assumptions transM[OF _ ‹M(A)›]
    by (rule_tac RepFun_closed, auto intro!:transM[OF _ ‹⋀x. x∈A ⟹  M(B(x))›])
  with assms
  show "{⟨x, b(x)⟩ . x ∈ A} ∈ Pow⇗M⇖(Sigma(A, B))"
    using Pow_rel_char by auto
qed

end ― ‹locale‹M_Pi_assumptions››

locale M_Pi_assumptions2 = M_Pi_assumptions +
  PiC: M_Pi_assumptions _ _ C for C
begin

lemma Pi_rel_type:
  assumes "f ∈ Pi⇗M⇖(A,C)" "⋀x. x ∈ A ⟹ f`x ∈ B(x)"
    and types: "M(f)"
  shows "f ∈ Pi⇗M⇖(A,B)"
  using assms Pi_assumptions
  by (simp only: Pi_rel_iff' PiC.Pi_rel_iff')
    (blast dest: function_apply_equality)

lemma Pi_rel_weaken_type:
  assumes "f ∈ Pi⇗M⇖(A,B)" "⋀x. x ∈ A ⟹ B(x) ⊆ C(x)"
    and types: "M(f)"
  shows "f ∈ Pi⇗M⇖(A,C)"
  using assms Pi_assumptions
  by (simp only: Pi_rel_iff' PiC.Pi_rel_iff')
    (blast intro: Pi_rel_type  dest: apply_type)

end ― ‹locale‹M_Pi_assumptions2››


end
div class="head">

Theory Arities

section‹Arities of internalized formulas›
theory Arities
  imports
    Discipline_Base
begin

lemmas FOL_arities [simp del, arity] = arity_And arity_Or arity_Implies arity_Iff arity_Exists

declare pred_Un_distrib[arity_aux]

context
  notes FOL_arities[simp]
begin

lemma arity_upair_fm [arity] : "⟦  t1∈nat ; t2∈nat ; up∈nat  ⟧ ⟹
  arity(upair_fm(t1,t2,up)) = ⋃ {succ(t1),succ(t2),succ(up)}"
  unfolding  upair_fm_def
  using union_abs1 union_abs2 pred_Un
  by auto

end

lemma Un_trasposition_aux1: "r ∪ s ∪ r = r ∪ s" by auto

lemma Un_trasposition_aux2:
  "r ∪ (s ∪ (r ∪ u))= r ∪ (s ∪ u)"
  "r ∪ (s ∪ (t ∪ (r ∪ u)))= r ∪ (s ∪ (t ∪ u))" by auto

txt‹Using the previous lemmas to guide the automatic arity calculation.›

context
  notes Un_assoc[symmetric,simp] Un_trasposition_aux1[simp]
begin

arity_theorem for "pair_fm"
arity_theorem for "composition_fm"
arity_theorem for "domain_fm"
arity_theorem for "range_fm"
arity_theorem for "union_fm"
arity_theorem for "image_fm"
arity_theorem for "pre_image_fm"
arity_theorem for "big_union_fm"
arity_theorem for "fun_apply_fm"
arity_theorem for "field_fm"
arity_theorem for "empty_fm"
arity_theorem for "cons_fm"
arity_theorem for "succ_fm"
arity_theorem for "number1_fm"
arity_theorem for "function_fm"
arity_theorem for "relation_fm"
arity_theorem for "restriction_fm"
arity_theorem for "typed_function_fm"
arity_theorem for "subset_fm"
arity_theorem for "transset_fm"
arity_theorem for "ordinal_fm"
arity_theorem for "limit_ordinal_fm"
arity_theorem for "finite_ordinal_fm"
arity_theorem for "omega_fm"
arity_theorem for "cartprod_fm"
arity_theorem for "singleton_fm"
arity_theorem for "Memrel_fm"
arity_theorem for "quasinat_fm"

end ― ‹context›

context
  notes FOL_arities[simp]
begin

lemma arity_is_recfun_fm [arity]:
  "⟦p∈formula ; v∈nat ; n∈nat; Z∈nat;i∈nat⟧ ⟹  arity(p) = i ⟹
  arity(is_recfun_fm(p,v,n,Z)) = succ(v) ∪ succ(n) ∪ succ(Z) ∪ pred(pred(pred(pred(i))))"
  unfolding is_recfun_fm_def
  using arity_upair_fm arity_pair_fm arity_pre_image_fm arity_restriction_fm
    union_abs2 pred_Un_distrib
  by auto

lemma arity_is_wfrec_fm [arity]:
  "⟦p∈formula ; v∈nat ; n∈nat; Z∈nat ; i∈nat⟧ ⟹ arity(p) = i ⟹
    arity(is_wfrec_fm(p,v,n,Z)) = succ(v) ∪ succ(n) ∪ succ(Z) ∪ pred(pred(pred(pred(pred(i)))))"
  unfolding is_wfrec_fm_def
  using arity_succ_fm  arity_is_recfun_fm
    union_abs2 pred_Un_distrib
  by auto

lemma arity_is_nat_case_fm [arity]:
  "⟦p∈formula ; v∈nat ; n∈nat; Z∈nat; i∈nat⟧ ⟹ arity(p) = i ⟹
    arity(is_nat_case_fm(v,p,n,Z)) = succ(v) ∪ succ(n) ∪ succ(Z) ∪ pred(pred(i))"
  unfolding is_nat_case_fm_def
  using arity_succ_fm arity_empty_fm arity_quasinat_fm
    union_abs2 pred_Un_distrib
  by auto

lemma arity_iterates_MH_fm [arity]:
  assumes "isF∈formula" "v∈nat" "n∈nat" "g∈nat" "z∈nat" "i∈nat"
    "arity(isF) = i"
  shows "arity(iterates_MH_fm(isF,v,n,g,z)) =
           succ(v) ∪ succ(n) ∪ succ(g) ∪ succ(z) ∪ pred(pred(pred(pred(i))))"
proof -
  let ?φ = "Exists(And(fun_apply_fm(succ(succ(succ(g))), 2, 0), Forall(Implies(Equal(0, 2), isF))))"
  let ?ar = "succ(succ(succ(g))) ∪ pred(pred(i))"
  from assms
  have "arity(?φ) =?ar" "?φ∈formula"
    using arity_fun_apply_fm
      union_abs1 union_abs2 pred_Un_distrib succ_Un_distrib Un_assoc[symmetric]
    by simp_all
  then
  show ?thesis
    unfolding iterates_MH_fm_def
    using arity_is_nat_case_fm[OF ‹?φ∈_› _ _ _ _ ‹arity(?φ) = ?ar›] assms pred_succ_eq pred_Un_distrib
    by auto
qed

lemma arity_is_iterates_fm [arity]:
  assumes "p∈formula" "v∈nat" "n∈nat" "Z∈nat" "i∈nat"
    "arity(p) = i"
  shows "arity(is_iterates_fm(p,v,n,Z)) = succ(v) ∪ succ(n) ∪ succ(Z) ∪
          pred(pred(pred(pred(pred(pred(pred(pred(pred(pred(pred(i)))))))))))"
proof -
  let ?φ = "iterates_MH_fm(p, 7+ωv, 2, 1, 0)"
  let ?ψ = "is_wfrec_fm(?φ, 0, succ(succ(n)),succ(succ(Z)))"
  from ‹v∈_›
  have "arity(?φ) = (8+ωv) ∪ pred(pred(pred(pred(i))))" "?φ∈formula"
    using assms arity_iterates_MH_fm union_abs2
    by simp_all
  then
  have "arity(?ψ) = succ(succ(succ(n))) ∪ succ(succ(succ(Z))) ∪ (3+ωv) ∪
      pred(pred(pred(pred(pred(pred(pred(pred(pred(i)))))))))"
    using assms arity_is_wfrec_fm[OF ‹?φ∈_› _ _ _ _ ‹arity(?φ) = _›] union_abs1 pred_Un_distrib
    by auto
  then
  show ?thesis
    unfolding is_iterates_fm_def
    using arity_Memrel_fm arity_succ_fm assms union_abs1 pred_Un_distrib
    by auto
qed

lemma arity_eclose_n_fm [arity]:
  assumes "A∈nat" "x∈nat" "t∈nat"
  shows "arity(eclose_n_fm(A,x,t)) = succ(A) ∪ succ(x) ∪ succ(t)"
proof -
  let ?φ = "big_union_fm(1,0)"
  have "arity(?φ) = 2" "?φ∈formula"
    using arity_big_union_fm union_abs2
    by auto
  with assms
  show ?thesis
    unfolding eclose_n_fm_def
    using arity_is_iterates_fm[OF ‹?φ∈_› _ _ _,of _ _ _ 2]
    by auto
qed

lemma arity_mem_eclose_fm [arity]:
  assumes "x∈nat" "t∈nat"
  shows "arity(mem_eclose_fm(x,t)) = succ(x) ∪ succ(t)"
proof -
  let ?φ="eclose_n_fm(x +ω 2, 1, 0)"
  from ‹x∈nat›
  have "arity(?φ) = x+ω3"
    using arity_eclose_n_fm union_abs2
    by simp
  with assms
  show ?thesis
    unfolding mem_eclose_fm_def
    using arity_finite_ordinal_fm union_abs2 pred_Un_distrib
    by simp
qed

lemma arity_is_eclose_fm [arity]:
  "⟦x∈nat ; t∈nat⟧ ⟹ arity(is_eclose_fm(x,t)) = succ(x) ∪ succ(t)"
  unfolding is_eclose_fm_def
  using arity_mem_eclose_fm union_abs2 pred_Un_distrib
  by auto

lemma arity_Collect_fm [arity]:
  assumes "x ∈ nat" "y ∈ nat" "p∈formula"
  shows "arity(Collect_fm(x,p,y)) = succ(x) ∪ succ(y) ∪ pred(arity(p))"
  unfolding Collect_fm_def
  using assms pred_Un_distrib
  by auto

schematic_goal arity_least_fm':
  assumes
    "i ∈ nat" "q ∈ formula"
  shows
    "arity(least_fm(q,i)) ≡ ?ar"
  unfolding least_fm_def
  using assms pred_Un_distrib arity_And arity_Or arity_Neg arity_Implies arity_ordinal_fm
    arity_empty_fm Un_assoc[symmetric] Un_commute
  by auto

lemma arity_least_fm [arity]:
  assumes
    "i ∈ nat" "q ∈ formula"
  shows
    "arity(least_fm(q,i)) = succ(i) ∪ pred(arity(q))"
  using assms arity_least_fm'
  by auto

lemma arity_Replace_fm [arity]:
  "⟦p∈formula ; v∈nat ; n∈nat; i∈nat⟧ ⟹ arity(p) = i ⟹
    arity(Replace_fm(v,p,n)) = succ(n) ∪ succ(v) ∪ pred(pred(i))"
  unfolding Replace_fm_def
  using union_abs2 pred_Un_distrib
  by auto

lemma arity_lambda_fm [arity]:
  "⟦p∈formula; v∈nat ; n∈nat; i∈nat⟧ ⟹  arity(p) = i ⟹
    arity(lambda_fm(p,v,n)) = succ(n) ∪ (succ(v) ∪ (pred^3(i)))"
  unfolding lambda_fm_def
  using arity_pair_fm pred_Un_distrib union_abs1 union_abs2
  by simp

lemma arity_transrec_fm [arity]:
  "⟦p∈formula ; v∈nat ; n∈nat; i∈nat⟧ ⟹ arity(p) = i ⟹
     arity(is_transrec_fm(p,v,n)) = succ(v) ∪ succ(n) ∪ (pred^8(i))"
  unfolding is_transrec_fm_def
  using arity Un_assoc[symmetric] pred_Un_distrib
  by simp

lemma arity_wfrec_replacement_fm :
  "⟦p∈formula ; v∈nat ; n∈nat; Z∈nat ; i∈nat⟧ ⟹ arity(p) = i ⟹
    arity(Exists(And(pair_fm(1,0,2),is_wfrec_fm(p,v,n,Z))))
   = 2 ∪ v ∪ n ∪ Z ∪ (pred^6(i))"
  unfolding is_wfrec_fm_def
  using arity_succ_fm  arity_is_recfun_fm union_abs2 pred_Un_distrib arity_pair_fm
  by auto

end ― ‹@{thm [source] FOL_arities}›

declare arity_subset_fm [simp del] arity_ordinal_fm[simp del, arity] arity_transset_fm[simp del]

context
  notes Un_assoc[symmetric,simp] Un_trasposition_aux1[simp]
begin
arity_theorem for "rtran_closure_mem_fm"
arity_theorem for "rtran_closure_fm"
arity_theorem for "tran_closure_fm"
end

context
  notes Un_assoc[simp] Un_trasposition_aux2[simp]
begin
arity_theorem for "injection_fm"
arity_theorem for "surjection_fm"
arity_theorem for "bijection_fm"
arity_theorem for "order_isomorphism_fm"
end

arity_theorem for "Inl_fm"
arity_theorem for "Inr_fm"
arity_theorem for "pred_set_fm"

end
>

Theory Discipline_Function

theory Discipline_Function
  imports
    Arities
begin

(**********************************************************)
paragraph‹Discipline for term‹fst››


(* ftype(p) ≡ THE a. ∃b. p = ⟨a, b⟩ *)
arity_theorem for "empty_fm"
arity_theorem for "upair_fm"
arity_theorem for "pair_fm"
definition
  is_fst :: "(i⇒o)⇒i⇒i⇒o" where
  "is_fst(M,x,t) ≡ (∃z[M]. pair(M,t,z,x)) ∨
                       (¬(∃z[M]. ∃w[M]. pair(M,w,z,x)) ∧ empty(M,t))"
synthesize "fst" from_definition "is_fst"
notation fst_fm (‹⋅fst'(_') is _⋅›)

arity_theorem for "fst_fm"

definition fst_rel ::  "[i⇒o,i] ⇒ i"  where
  "fst_rel(M,p) ≡ THE d. M(d) ∧ is_fst(M,p,d)"

reldb_add relational "fst" "is_fst"
reldb_add functional "fst" "fst_rel"

definition
  is_snd :: "(i⇒o)⇒i⇒i⇒o" where
  "is_snd(M,x,t) ≡ (∃z[M]. pair(M,z,t,x)) ∨
                       (¬(∃z[M]. ∃w[M]. pair(M,z,w,x)) ∧ empty(M,t))"
synthesize "snd" from_definition "is_snd"
notation snd_fm (‹⋅snd'(_') is _⋅›)
arity_theorem for "snd_fm"

definition snd_rel ::  "[i⇒o,i] ⇒ i"  where
  "snd_rel(M,p) ≡ THE d. M(d) ∧ is_snd(M,p,d)"


reldb_add relational "snd" "is_snd"
reldb_add functional "snd" "snd_rel"

context M_trans
begin

lemma fst_snd_closed:
  assumes "M(p)"
  shows "M(fst(p)) ∧ M(snd(p))"
  unfolding fst_def snd_def using assms
  by (cases "∃a. ∃b. p = ⟨a, b⟩";auto)

lemma fst_closed[intro,simp]: "M(x) ⟹ M(fst(x))"
  using fst_snd_closed by auto

lemma snd_closed[intro,simp]: "M(x) ⟹ M(snd(x))"
  using fst_snd_closed by auto

lemma fst_abs [absolut]:
  "⟦M(p); M(x) ⟧ ⟹ is_fst(M,p,x) ⟷ x = fst(p)"
  unfolding is_fst_def fst_def
  by (cases "∃a. ∃b. p = ⟨a, b⟩";auto)

lemma snd_abs [absolut]:
  "⟦M(p); M(y) ⟧ ⟹ is_snd(M,p,y) ⟷ y = snd(p)"
  unfolding is_snd_def snd_def
  by (cases "∃a. ∃b. p = ⟨a, b⟩";auto)

lemma empty_rel_abs : "M(x) ⟹ M(0) ⟹ x = 0 ⟷ x = (THE d. M(d) ∧ empty(M, d))"
  unfolding the_def
  using transM
  by auto

lemma fst_rel_abs:
  assumes "M(p)"
  shows "fst(p) = fst_rel(M,p)"
  using fst_abs assms
  unfolding fst_def fst_rel_def
  by (cases "∃a. ∃b. p = ⟨a, b⟩";auto;rule_tac the_equality[symmetric],simp_all)

lemma snd_rel_abs:
  assumes "M(p)"
  shows "snd(p) = snd_rel(M,p)"
  using snd_abs assms
  unfolding snd_def snd_rel_def
  by (cases "∃a. ∃b. p = ⟨a, b⟩";auto;rule_tac the_equality[symmetric],simp_all)

end ― ‹locale‹M_trans››

relativize functional "first" "first_rel" external
relativize functional "minimum" "minimum_rel" external
context M_trans
begin

lemma minimum_closed[simp,intro]:
  assumes "M(A)"
  shows "M(minimum(r,A))"
  using first_is_elem the_equality_if transM[OF _ ‹M(A)›]
  by(cases "∃x . first(x,A,r)",auto simp:minimum_def)

lemma first_abs :
  assumes "M(B)"
  shows "first(z,B,r) ⟷ first_rel(M,z,B,r)"
  unfolding first_def first_rel_def using assms by auto

(* TODO: find a naming convention for absoluteness results like this.
See notes/TODO.txt
*)
lemma minimum_abs:
  assumes "M(B)"
  shows "minimum(r,B) = minimum_rel(M,r,B)"
proof -
  from assms
  have "first(b, B, r) ⟷ M(b) ∧ first_rel(M,b,B,r)" for b
    using first_abs
  proof (auto)
    fix b
    assume "first_rel(M,b,B,r)"
    with ‹M(B)›
    have "b∈B" using first_abs first_is_elem by simp
    with ‹M(B)›
    show "M(b)" using transM[OF ‹b∈B›] by simp
  qed
  with assms
  show ?thesis unfolding minimum_rel_def minimum_def
    by simp
qed

end ― ‹locale‹M_trans››

subsection‹Discipline for term‹function_space››

definition
  is_function_space :: "[i⇒o,i,i,i] ⇒ o"  where
  "is_function_space(M,A,B,fs) ≡ M(fs) ∧ is_funspace(M,A,B,fs)"

definition
  function_space_rel :: "[i⇒o,i,i] ⇒ i"  where
  "function_space_rel(M,A,B) ≡ THE d. is_function_space(M,A,B,d)"

reldb_rem absolute "Pi"
reldb_add relational "Pi" "is_function_space"
reldb_add functional "Pi" "function_space_rel"

abbreviation
  function_space_r :: "[i,i⇒o,i] ⇒ i" (‹_ →⇗_⇖ _› [61,1,61] 60) where
  "A →⇗M⇖ B ≡ function_space_rel(M,A,B)"

abbreviation
  function_space_r_set ::  "[i,i,i] ⇒ i" (‹_ →⇗_⇖ _› [61,1,61] 60) where
  "function_space_r_set(A,M) ≡ function_space_rel(##M,A)"

context M_Pi
begin

lemma is_function_space_uniqueness:
  assumes
    "M(r)" "M(B)"
    "is_function_space(M,r,B,d)" "is_function_space(M,r,B,d')"
  shows
    "d=d'"
  using assms extensionality_trans
  unfolding is_function_space_def is_funspace_def
  by simp

lemma is_function_space_witness:
  assumes "M(A)" "M(B)"
  shows "∃d[M]. is_function_space(M,A,B,d)"
proof -
  from assms
  interpret M_Pi_assumptions M A "λ_. B"
    using Pi_replacement Pi_separation
    by unfold_locales (auto dest:transM simp add:Sigfun_def)
  have "∀f[M]. f ∈ Pi_rel(M,A, λ_. B) ⟷ f ∈ A → B"
    using Pi_rel_char by simp
  with assms
  show ?thesis unfolding is_funspace_def is_function_space_def by auto
qed

lemma is_function_space_closed :
  "is_function_space(M,A,B,d) ⟹ M(d)"
  unfolding is_function_space_def by simp

― ‹adding closure to simpset and claset›
lemma function_space_rel_closed[intro,simp]:
  assumes "M(x)" "M(y)"
  shows "M(function_space_rel(M,x,y))"
proof -
  have "is_function_space(M, x, y, THE xa. is_function_space(M, x, y, xa))"
    using assms
      theI[OF ex1I[of "is_function_space(M,x,y)"], OF _ is_function_space_uniqueness[of x y]]
      is_function_space_witness
    by auto
  then show ?thesis
    using assms is_function_space_closed
    unfolding function_space_rel_def
    by blast
qed

lemmas trans_function_space_rel_closed[trans_closed] = transM[OF _ function_space_rel_closed]

lemma is_function_space_iff:
  assumes "M(x)" "M(y)" "M(d)"
  shows "is_function_space(M,x,y,d) ⟷ d = function_space_rel(M,x,y)"
proof (intro iffI)
  assume "d = function_space_rel(M,x,y)"
  moreover
  note assms
  moreover from this
  obtain e where "M(e)" "is_function_space(M,x,y,e)"
    using is_function_space_witness by blast
  ultimately
  show "is_function_space(M, x, y, d)"
    using is_function_space_uniqueness[of x y] is_function_space_witness
      theI[OF ex1I[of "is_function_space(M,x,y)"], OF _ is_function_space_uniqueness[of x y], of e]
    unfolding function_space_rel_def
    by auto
next
  assume "is_function_space(M, x, y, d)"
  with assms
  show "d = function_space_rel(M,x,y)"
    using is_function_space_uniqueness unfolding function_space_rel_def
    by (blast del:the_equality intro:the_equality[symmetric])
qed


lemma def_function_space_rel:
  assumes "M(A)" "M(y)"
  shows "function_space_rel(M,A,y) = Pi_rel(M,A,λ_. y)"
proof -
  from assms
  interpret M_Pi_assumptions M A "λ_. y"
    using Pi_replacement Pi_separation
    by unfold_locales (auto dest:transM simp add:Sigfun_def)
  from assms
  have "x∈function_space_rel(M,A,y) ⟷ x∈Pi_rel(M,A,λ_. y)" if "M(x)" for x
    using that
      is_function_space_iff[of A y, OF _ _ function_space_rel_closed, of A y]
      def_Pi_rel Pi_rel_char mbnr.Pow_rel_char
    unfolding is_function_space_def is_funspace_def by (simp add:Pi_def)
  with assms
  show ?thesis ― ‹At this point, quoting "trans\_rules" doesn't work›
    using transM[OF _ function_space_rel_closed, OF _ ‹M(A)› ‹M(y)›]
      transM[OF _ Pi_rel_closed] by blast
qed

lemma function_space_rel_char:
  assumes "M(A)" "M(y)"
  shows "function_space_rel(M,A,y) = {f ∈ A → y. M(f)}"
proof -
  from assms
  interpret M_Pi_assumptions M A "λ_. y"
    using Pi_replacement Pi_separation
    by unfold_locales (auto dest:transM simp add:Sigfun_def)
  show ?thesis
    using assms def_function_space_rel Pi_rel_char
    by simp
qed

lemma mem_function_space_rel_abs:
  assumes "M(A)" "M(y)" "M(f)"
  shows "f ∈ function_space_rel(M,A,y) ⟷  f ∈ A → y"
  using assms function_space_rel_char by simp

end ― ‹locale‹M_Pi››

locale M_N_Pi = M:M_Pi + N:M_Pi N for N +
  assumes
    M_imp_N:"M(x) ⟹ N(x)"
begin

lemma function_space_rel_transfer: "M(A) ⟹ M(B) ⟹
                          function_space_rel(M,A,B) ⊆ function_space_rel(N,A,B)"
  using M.function_space_rel_char N.function_space_rel_char
  by (auto dest!:M_imp_N)

end ― ‹locale‹M_N_Pi››

(*****************  end Discipline  ***********************)

abbreviation
  "is_apply ≡ fun_apply"
  ― ‹It is not necessary to perform the Discipline for term‹is_apply›
  since it is absolute in this context›

subsection‹Discipline for term‹Collect› terms.›

text‹We have to isolate the predicate involved and apply the
Discipline to it.›

(*************** Discipline for injP ******************)


definition (* completely relational *)
  injP_rel:: "[i⇒o,i,i]⇒o" where
  "injP_rel(M,A,f) ≡ ∀w[M]. ∀x[M]. ∀fw[M]. ∀fx[M]. w∈A ∧ x∈A ∧
            is_apply(M,f,w,fw) ∧ is_apply(M,f,x,fx) ∧ fw=fx⟶ w=x"

synthesize "injP_rel" from_definition assuming "nonempty"

arity_theorem for "injP_rel_fm"

context M_basic
begin

― ‹I'm undecided on keeping the relative quantifiers here.
    Same with term‹surjP› below. It might relieve from changing
    @{thm exI allI} to @{thm rexI rallI} in some proofs.
    I wonder if this escalates well. Assuming that all terms
    appearing in the "def\_" theorem are in term‹M› and using
    @{thm transM}, it might do.›
lemma def_injP_rel:
  assumes
    "M(A)" "M(f)"
  shows
    "injP_rel(M,A,f) ⟷ (∀w[M]. ∀x[M]. w∈A ∧ x∈A ∧ f`w=f`x ⟶ w=x)"
  using assms unfolding injP_rel_def by simp

end ― ‹locale‹M_basic››

(******************  end Discipline  **********************)

(**********************************************************)
subsection‹Discipline for term‹inj››

definition (* completely relational *)
  is_inj   :: "[i⇒o,i,i,i]⇒o"  where
  "is_inj(M,A,B,I) ≡ M(I) ∧ (∃F[M]. is_function_space(M,A,B,F) ∧
       is_Collect(M,F,injP_rel(M,A),I))"


declare typed_function_iff_sats Collect_iff_sats [iff_sats]

synthesize "is_funspace" from_definition assuming "nonempty"
arity_theorem for "is_funspace_fm"

synthesize "is_function_space" from_definition assuming "nonempty"
notation is_function_space_fm (‹⋅_ → _ is _⋅›)

arity_theorem for "is_function_space_fm"

synthesize "is_inj" from_definition assuming "nonempty"
notation is_inj_fm (‹⋅inj'(_,_') is _⋅›)

arity_theorem intermediate for "is_inj_fm"

lemma arity_is_inj_fm[arity]:
  "A ∈ nat ⟹
    B ∈ nat ⟹ I ∈ nat ⟹ arity(is_inj_fm(A, B, I)) = succ(A) ∪ succ(B) ∪ succ(I)"
  using arity_is_inj_fm' by (auto simp:pred_Un_distrib arity)

definition
  inj_rel :: "[i⇒o,i,i] ⇒ i" (‹inj⇗_⇖'(_,_')›) where
  "inj_rel(M,A,B) ≡ THE d. is_inj(M,A,B,d)"

abbreviation
  inj_r_set ::  "[i,i,i] ⇒ i" (‹inj⇗_⇖'(_,_')›) where
  "inj_r_set(M) ≡ inj_rel(##M)"

locale M_inj = M_Pi +
  assumes
    injP_separation: "M(r) ⟹ separation(M,injP_rel(M, r))"
begin

lemma is_inj_uniqueness:
  assumes
    "M(r)" "M(B)"
    "is_inj(M,r,B,d)" "is_inj(M,r,B,d')"
  shows
    "d=d'"
  using assms is_function_space_iff extensionality_trans
  unfolding is_inj_def by simp

lemma is_inj_witness: "M(r) ⟹ M(B)⟹ ∃d[M]. is_inj(M,r,B,d)"
  using injP_separation is_function_space_iff
  unfolding is_inj_def by simp

lemma is_inj_closed :
  "is_inj(M,x,y,d) ⟹ M(d)"
  unfolding is_inj_def by simp

lemma inj_rel_closed[intro,simp]:
  assumes "M(x)" "M(y)"
  shows "M(inj_rel(M,x,y))"
proof -
  have "is_inj(M, x, y, THE xa. is_inj(M, x, y, xa))"
    using assms
      theI[OF ex1I[of "is_inj(M,x,y)"], OF _ is_inj_uniqueness[of x y]]
      is_inj_witness
    by auto
  then show ?thesis
    using assms is_inj_closed
    unfolding inj_rel_def
    by blast
qed

lemmas trans_inj_rel_closed[trans_closed] = transM[OF _ inj_rel_closed]

lemma inj_rel_iff:
  assumes "M(x)" "M(y)" "M(d)"
  shows "is_inj(M,x,y,d) ⟷ d = inj_rel(M,x,y)"
proof (intro iffI)
  assume "d = inj_rel(M,x,y)"
  moreover
  note assms
  moreover from this
  obtain e where "M(e)" "is_inj(M,x,y,e)"
    using is_inj_witness by blast
  ultimately
  show "is_inj(M, x, y, d)"
    using is_inj_uniqueness[of x y] is_inj_witness
      theI[OF ex1I[of "is_inj(M,x,y)"], OF _ is_inj_uniqueness[of x y], of e]
    unfolding inj_rel_def
    by auto
next
  assume "is_inj(M, x, y, d)"
  with assms
  show "d = inj_rel(M,x,y)"
    using is_inj_uniqueness unfolding inj_rel_def
    by (blast del:the_equality intro:the_equality[symmetric])
qed

lemma def_inj_rel:
  assumes "M(A)" "M(B)"
  shows "inj_rel(M,A,B) =
         {f ∈ function_space_rel(M,A,B).  ∀w[M]. ∀x[M]. w∈A ∧ x∈A ∧ f`w = f`x ⟶ w=x}"
    (is "_ = Collect(_,?P)")
proof -
  from assms
  have "inj_rel(M,A,B) ⊆ function_space_rel(M,A,B)"
    using inj_rel_iff[of A B "inj_rel(M,A,B)"] is_function_space_iff
    unfolding is_inj_def by auto
  moreover from assms
  have "f ∈ inj_rel(M,A,B) ⟹ ?P(f)" for f
    using inj_rel_iff[of A B "inj_rel(M,A,B)"] is_function_space_iff
      def_injP_rel transM[OF _ function_space_rel_closed, OF _ ‹M(A)› ‹M(B)›]
    unfolding is_inj_def by auto
  moreover from assms
  have "f ∈ function_space_rel(M,A,B) ⟹ ?P(f) ⟹ f ∈ inj_rel(M,A,B)" for f
    using inj_rel_iff[of A B "inj_rel(M,A,B)"] is_function_space_iff
      def_injP_rel transM[OF _ function_space_rel_closed, OF _ ‹M(A)› ‹M(B)›]
    unfolding is_inj_def by auto
  ultimately
  show ?thesis by force
qed

lemma inj_rel_char:
  assumes "M(A)" "M(B)"
  shows "inj_rel(M,A,B) = {f ∈ inj(A,B). M(f)}"
proof -
  from assms
  interpret M_Pi_assumptions M A "λ_. B"
    using Pi_replacement Pi_separation
    by unfold_locales (auto dest:transM simp add:Sigfun_def)
  from assms
  show ?thesis
    using def_inj_rel[OF assms] def_function_space_rel[OF assms]
      transM[OF _ ‹M(A)›] Pi_rel_char
    unfolding inj_def
    by auto
qed


end ― ‹locale‹M_inj››

locale M_N_inj = M:M_inj + N:M_inj N for N +
  assumes
    M_imp_N:"M(x) ⟹ N(x)"
begin

lemma inj_rel_transfer: "M(A) ⟹ M(B) ⟹ inj_rel(M,A,B) ⊆ inj_rel(N,A,B)"
  using M.inj_rel_char N.inj_rel_char
  by (auto dest!:M_imp_N)

end ― ‹locale‹M_N_inj››


(***************  end Discipline  *********************)

(*************** Discipline for surjP ******************)

definition
  surjP_rel:: "[i⇒o,i,i,i]⇒o" where
  "surjP_rel(M,A,B,f) ≡
    ∀y[M]. ∃x[M]. ∃fx[M]. y∈B ⟶ x∈A ∧ is_apply(M,f,x,fx) ∧ fx=y"

synthesize "surjP_rel" from_definition assuming "nonempty"

context M_basic
begin

lemma def_surjP_rel:
  assumes
    "M(A)" "M(B)" "M(f)"
  shows
    "surjP_rel(M,A,B,f) ⟷ (∀y[M]. ∃x[M]. y∈B ⟶ x∈A ∧ f`x=y)"
  using assms unfolding surjP_rel_def by auto

end ― ‹locale‹M_basic››

(******************  end Discipline  **********************)

(**********************************************************)
subsection‹Discipline for term‹surj››

definition (* completely relational *)
  is_surj   :: "[i⇒o,i,i,i]⇒o"  where
  "is_surj(M,A,B,I) ≡ M(I) ∧ (∃F[M]. is_function_space(M,A,B,F) ∧
       is_Collect(M,F,surjP_rel(M,A,B),I))"

synthesize "is_surj" from_definition assuming "nonempty"
notation is_surj_fm (‹⋅surj'(_,_') is _⋅›)

definition
  surj_rel :: "[i⇒o,i,i] ⇒ i" (‹surj⇗_⇖'(_,_')›) where
  "surj_rel(M,A,B) ≡ THE d. is_surj(M,A,B,d)"

abbreviation
  surj_r_set ::  "[i,i,i] ⇒ i" (‹surj⇗_⇖'(_,_')›) where
  "surj_r_set(M) ≡ surj_rel(##M)"

locale M_surj = M_Pi +
  assumes
    surjP_separation: "M(A)⟹M(B)⟹separation(M,λx. surjP_rel(M,A,B,x))"
begin

lemma is_surj_uniqueness:
  assumes
    "M(r)" "M(B)"
    "is_surj(M,r,B,d)" "is_surj(M,r,B,d')"
  shows
    "d=d'"
  using assms is_function_space_iff extensionality_trans
  unfolding is_surj_def by simp

lemma is_surj_witness: "M(r) ⟹ M(B)⟹ ∃d[M]. is_surj(M,r,B,d)"
  using surjP_separation is_function_space_iff
  unfolding is_surj_def by simp

lemma is_surj_closed :
  "is_surj(M,x,y,d) ⟹ M(d)"
  unfolding is_surj_def by simp

lemma surj_rel_closed[intro,simp]:
  assumes "M(x)" "M(y)"
  shows "M(surj_rel(M,x,y))"
proof -
  have "is_surj(M, x, y, THE xa. is_surj(M, x, y, xa))"
    using assms
      theI[OF ex1I[of "is_surj(M,x,y)"], OF _ is_surj_uniqueness[of x y]]
      is_surj_witness
    by auto
  then show ?thesis
    using assms is_surj_closed
    unfolding surj_rel_def
    by blast
qed

lemmas trans_surj_rel_closed[trans_closed] = transM[OF _ surj_rel_closed]

lemma surj_rel_iff:
  assumes "M(x)" "M(y)" "M(d)"
  shows "is_surj(M,x,y,d) ⟷ d = surj_rel(M,x,y)"
proof (intro iffI)
  assume "d = surj_rel(M,x,y)"
  moreover
  note assms
  moreover from this
  obtain e where "M(e)" "is_surj(M,x,y,e)"
    using is_surj_witness by blast
  ultimately
  show "is_surj(M, x, y, d)"
    using is_surj_uniqueness[of x y] is_surj_witness
      theI[OF ex1I[of "is_surj(M,x,y)"], OF _ is_surj_uniqueness[of x y], of e]
    unfolding surj_rel_def
    by auto
next
  assume "is_surj(M, x, y, d)"
  with assms
  show "d = surj_rel(M,x,y)"
    using is_surj_uniqueness unfolding surj_rel_def
    by (blast del:the_equality intro:the_equality[symmetric])
qed

lemma def_surj_rel:
  assumes "M(A)" "M(B)"
  shows "surj_rel(M,A,B) =
         {f ∈ function_space_rel(M,A,B). ∀y[M]. ∃x[M]. y∈B ⟶ x∈A ∧ f`x=y }"
    (is "_ = Collect(_,?P)")
proof -
  from assms
  have "surj_rel(M,A,B) ⊆ function_space_rel(M,A,B)"
    using surj_rel_iff[of A B "surj_rel(M,A,B)"] is_function_space_iff
    unfolding is_surj_def by auto
  moreover from assms
  have "f ∈ surj_rel(M,A,B) ⟹ ?P(f)" for f
    using surj_rel_iff[of A B "surj_rel(M,A,B)"] is_function_space_iff
      def_surjP_rel transM[OF _ function_space_rel_closed, OF _ ‹M(A)› ‹M(B)›]
    unfolding is_surj_def by auto
  moreover from assms
  have "f ∈ function_space_rel(M,A,B) ⟹ ?P(f) ⟹ f ∈ surj_rel(M,A,B)" for f
    using surj_rel_iff[of A B "surj_rel(M,A,B)"] is_function_space_iff
      def_surjP_rel transM[OF _ function_space_rel_closed, OF _ ‹M(A)› ‹M(B)›]
    unfolding is_surj_def by auto
  ultimately
  show ?thesis by force
qed

lemma surj_rel_char:
  assumes "M(A)" "M(B)"
  shows "surj_rel(M,A,B) = {f ∈ surj(A,B). M(f)}"
proof -
  from assms
  interpret M_Pi_assumptions M A "λ_. B"
    using Pi_replacement Pi_separation
    by unfold_locales (auto dest:transM simp add:Sigfun_def)
  from assms
  show ?thesis
    using def_surj_rel[OF assms] def_function_space_rel[OF assms]
      transM[OF _ ‹M(A)›] transM[OF _ ‹M(B)›] Pi_rel_char
    unfolding surj_def
    by auto
qed

end ― ‹locale‹M_surj››

locale M_N_surj = M:M_surj + N:M_surj N for N +
  assumes
    M_imp_N:"M(x) ⟹ N(x)"
begin

lemma surj_rel_transfer: "M(A) ⟹ M(B) ⟹ surj_rel(M,A,B) ⊆ surj_rel(N,A,B)"
  using M.surj_rel_char N.surj_rel_char
  by (auto dest!:M_imp_N)

end ― ‹locale‹M_N_surj››

(***************  end Discipline  *********************)

definition
  is_Int :: "[i⇒o,i,i,i]⇒o"  where
  "is_Int(M,A,B,I) ≡ M(I) ∧ (∀x[M]. x ∈ I ⟷ x ∈ A ∧ x ∈ B)"

reldb_rem relational "inter"
reldb_add absolute relational "ZF_Base.Int" "is_Int"

synthesize "is_Int" from_definition assuming "nonempty"
notation is_Int_fm (‹_ ∩ _ is _›)

context M_basic
begin

lemma is_Int_closed :
  "is_Int(M,A,B,I) ⟹ M(I)"
  unfolding is_Int_def by simp

lemma is_Int_abs:
  assumes
    "M(A)" "M(B)" "M(I)"
  shows
    "is_Int(M,A,B,I) ⟷ I = A ∩ B"
  using assms transM[OF _ ‹M(B)›] transM[OF _ ‹M(I)›]
  unfolding is_Int_def by blast

lemma is_Int_uniqueness:
  assumes
    "M(r)" "M(B)"
    "is_Int(M,r,B,d)" "is_Int(M,r,B,d')"
  shows
    "d=d'"
proof -
  have "M(d)" and "M(d')"
    using assms is_Int_closed by simp+
  then show ?thesis
    using assms is_Int_abs by simp
qed

text‹Note: @{thm Int_closed} already in theory‹ZF-Constructible.Relative›.›

end ― ‹locale‹M_basic››

(**********************************************************)
subsection‹Discipline for term‹bij››

reldb_add functional "inj" "inj_rel"
reldb_add functional relational "inj_rel" "is_inj"
reldb_add functional "surj" "surj_rel"
reldb_add functional relational "surj_rel" "is_surj"
relativize functional "bij" "bij_rel" external
relationalize "bij_rel" "is_bij"

(* definition (* completely relational *)
  is_bij   :: "[i⇒o,i,i,i]⇒o"  where
  "is_bij(M,A,B,bj) ≡ M(bj) ∧ is_hcomp2_2(M,is_Int,is_inj,is_surj,A,B,bj)"

definition
  bij_rel :: "[i⇒o,i,i] ⇒ i" (‹bij_'(_,_')›) where
  "bij_rel(M,A,B) ≡ THE d. is_bij(M,A,B,d)" *)

synthesize "is_bij" from_definition assuming "nonempty"
notation is_bij_fm (‹⋅bij'(_,_') is _⋅›)

abbreviation
  bij_r_class ::  "[i⇒o,i,i] ⇒ i" (‹bij⇗_⇖'(_,_')›) where
  "bij_r_class ≡ bij_rel"

abbreviation
  bij_r_set ::  "[i,i,i] ⇒ i" (‹bij⇗_⇖'(_,_')›) where
  "bij_r_set(M) ≡ bij_rel(##M)"

locale M_Perm = M_Pi + M_inj + M_surj
begin

lemma is_bij_closed : "is_bij(M,f,y,d) ⟹ M(d)"
  unfolding is_bij_def using is_Int_closed is_inj_witness is_surj_witness by auto

lemma bij_rel_closed[intro,simp]:
  assumes "M(x)" "M(y)"
  shows "M(bij_rel(M,x,y))"
  unfolding bij_rel_def
  using assms Int_closed surj_rel_closed inj_rel_closed
  by auto

lemmas trans_bij_rel_closed[trans_closed] = transM[OF _ bij_rel_closed]

lemma bij_rel_iff:
  assumes "M(x)" "M(y)" "M(d)"
  shows "is_bij(M,x,y,d) ⟷ d = bij_rel(M,x,y)"
  unfolding is_bij_def bij_rel_def
  using assms surj_rel_iff inj_rel_iff is_Int_abs
  by auto

lemma def_bij_rel:
  assumes "M(A)" "M(B)"
  shows "bij_rel(M,A,B) = inj_rel(M,A,B) ∩ surj_rel(M,A,B)"
  using assms bij_rel_iff inj_rel_iff surj_rel_iff
    is_Int_abs― ‹For absolute terms, "\_abs" replaces "\_iff".
                 Also, in this case "\_closed" is in the simpset.›
  unfolding is_bij_def by simp

lemma bij_rel_char:
  assumes "M(A)" "M(B)"
  shows "bij_rel(M,A,B) = {f ∈ bij(A,B). M(f)}"
  using assms def_bij_rel inj_rel_char surj_rel_char
  unfolding bij_def― ‹Unfolding this might be a pattern already›
  by auto

end ― ‹locale‹M_Perm››

locale M_N_Perm = M_N_Pi + M_N_inj + M_N_surj + M:M_Perm + N:M_Perm N

begin

lemma bij_rel_transfer: "M(A) ⟹ M(B) ⟹ bij_rel(M,A,B) ⊆ bij_rel(N,A,B)"
  using M.bij_rel_char N.bij_rel_char
  by (auto dest!:M_imp_N)

end ― ‹locale‹M_N_Perm››

(***************  end Discipline  *********************)

(******************************************************)
subsection‹Discipline for term‹eqpoll››

relativize functional "eqpoll" "eqpoll_rel" external
relationalize "eqpoll_rel" "is_eqpoll"

synthesize "is_eqpoll" from_definition assuming "nonempty"
arity_theorem for "is_eqpoll_fm"
notation is_eqpoll_fm (‹⋅_ ≈ _⋅›)

context M_Perm begin

is_iff_rel for "eqpoll"
  using bij_rel_iff unfolding is_eqpoll_def eqpoll_rel_def by simp

end ― ‹locale‹M_Perm››

abbreviation
  eqpoll_r :: "[i,i⇒o,i] => o" (‹_ ≈⇗_⇖ _› [51,1,51] 50) where
  "A ≈⇗M⇖ B ≡ eqpoll_rel(M,A,B)"

abbreviation
  eqpoll_r_set ::  "[i,i,i] ⇒ o" (‹_ ≈⇗_⇖ _› [51,1,51] 50) where
  "eqpoll_r_set(A,M) ≡ eqpoll_rel(##M,A)"

context M_Perm
begin

lemma def_eqpoll_rel:
  assumes
    "M(A)" "M(B)"
  shows
    "eqpoll_rel(M,A,B) ⟷ (∃f[M]. f ∈ bij_rel(M,A,B))"
  using assms bij_rel_iff
  unfolding eqpoll_rel_def by simp

end ― ‹locale‹M_Perm››

context M_N_Perm
begin

(* the next lemma is not part of the discipline *)
lemma eqpoll_rel_transfer: assumes "A ≈⇗M⇖ B" "M(A)" "M(B)"
  shows "A ≈⇗N⇖ B"
proof -
  note assms
  moreover from this
  obtain f where "f ∈ bij⇗M⇖(A,B)" "N(f)"
    using M.def_eqpoll_rel by (auto dest!:M_imp_N)
  moreover from calculation
  have "f ∈ bij⇗N⇖(A,B)"
    using bij_rel_transfer by (auto)
  ultimately
  show ?thesis
    using N.def_eqpoll_rel by (blast dest!:M_imp_N)
qed

end ― ‹locale‹M_N_Perm››

(******************  end Discipline  ******************)

(******************************************************)
subsection‹Discipline for term‹lepoll››

relativize functional "lepoll" "lepoll_rel" external
relationalize "lepoll_rel" "is_lepoll"

synthesize "is_lepoll" from_definition assuming "nonempty"
notation is_lepoll_fm (‹⋅_ ≲ _⋅›)
arity_theorem for "is_lepoll_fm"

context M_inj begin

is_iff_rel for "lepoll"
  using inj_rel_iff unfolding is_lepoll_def lepoll_rel_def by simp

end ― ‹locale‹M_inj››

abbreviation
  lepoll_r :: "[i,i⇒o,i] => o" (‹_ ≲⇗_⇖ _› [51,1,51] 50) where
  "A ≲⇗M⇖ B ≡ lepoll_rel(M,A,B)"

abbreviation
  lepoll_r_set ::  "[i,i,i] ⇒ o" (‹_ ≲⇗_⇖ _› [51,1,51] 50) where
  "lepoll_r_set(A,M) ≡ lepoll_rel(##M,A)"

context M_Perm
begin

lemma def_lepoll_rel:
  assumes
    "M(A)" "M(B)"
  shows
    "lepoll_rel(M,A,B) ⟷ (∃f[M]. f ∈ inj_rel(M,A,B))"
  using assms inj_rel_iff
  unfolding lepoll_rel_def by simp

end ― ‹locale‹M_Perm››

context M_N_Perm
begin

(* the next lemma is not part of the discipline *)
lemma lepoll_rel_transfer: assumes "A ≲⇗M⇖ B" "M(A)" "M(B)"
  shows "A ≲⇗N⇖ B"
proof -
  note assms
  moreover from this
  obtain f where "f ∈ inj⇗M⇖(A,B)" "N(f)"
    using M.def_lepoll_rel by (auto dest!:M_imp_N)
  moreover from calculation
  have "f ∈ inj⇗N⇖(A,B)"
    using inj_rel_transfer by (auto)
  ultimately
  show ?thesis
    using N.def_lepoll_rel by (blast dest!:M_imp_N)
qed

end ― ‹locale‹M_N_Perm››

(******************  end Discipline  ******************)

(******************************************************)
subsection‹Discipline for term‹lesspoll››

relativize functional "lesspoll" "lesspoll_rel" external
relationalize "lesspoll_rel" "is_lesspoll"

synthesize "is_lesspoll" from_definition assuming "nonempty"
notation is_lesspoll_fm (‹⋅_ ≺ _⋅›)
arity_theorem for "is_lesspoll_fm"

context M_Perm begin

is_iff_rel for "lesspoll"
  using is_lepoll_iff is_eqpoll_iff
  unfolding is_lesspoll_def lesspoll_rel_def by simp

end ― ‹locale‹M_Perm››

abbreviation
  lesspoll_r :: "[i,i⇒o,i] => o" (‹_ ≺⇗_⇖ _› [51,1,51] 50) where
  "A ≺⇗M⇖ B ≡ lesspoll_rel(M,A,B)"

abbreviation
  lesspoll_r_set ::  "[i,i,i] ⇒ o" (‹_ ≺⇗_⇖ _› [51,1,51] 50) where
  "lesspoll_r_set(A,M) ≡ lesspoll_rel(##M,A)"

text‹Since term‹lesspoll_rel› is defined as a propositional
combination of older terms, there is no need for a separate ``def''
theorem for it.›

text‹Note that term‹lesspoll_rel› is neither $\Sigma_1^{\mathit{ZF}}$ nor
 $\Pi_1^{\mathit{ZF}}$, so there is no ``transfer'' theorem for it.›

end

Theory Lambda_Replacement

section‹Replacements using Lambdas›

theory Lambda_Replacement
  imports
    Discipline_Function
begin

text‹In this theory we prove several instances of separation and replacement
in @{locale M_basic}. Moreover we introduce a new locale assuming two instances
of separation and twelve instances of lambda replacements (ie, replacement of
the form $\lambda x y. y=\langle x, f(x) \rangle$) we prove a bunch of other
instances.›


definition
  lam_replacement :: "[i⇒o,i⇒i] ⇒ o" where
  "lam_replacement(M,b) ≡ strong_replacement(M, λx y. y = ⟨x, b(x)⟩)"

lemma separation_univ :
  shows "separation(M,M)"
  unfolding separation_def by auto

context M_basic
begin

lemma separation_iff':
  assumes "separation(M,λx . P(x))" "separation(M,λx . Q(x))"
  shows "separation(M,λx . P(x) ⟷ Q(x))"
  using assms separation_conj separation_imp iff_def
  by auto

lemma separation_in_constant :
  assumes "M(a)"
  shows "separation(M,λx . x∈a)"
proof -
  have "{x∈A . x∈a} = A ∩ a" for A by auto
  with ‹M(a)›
  show ?thesis using separation_iff Collect_abs
    by simp
qed

lemma separation_equal :
  shows "separation(M,λx . x=a)"
proof -
  have "{x∈A . x=a} = (if a∈A then {a} else 0)" for A
    by auto
  then
  have "M({x∈A . x=a})" if "M(A)" for A
    using transM[OF _ ‹M(A)›] by simp
  then
  show ?thesis using separation_iff Collect_abs
    by simp
qed

lemma (in M_basic) separation_in_rev:
  assumes "(M)(a)"
  shows "separation(M,λx . a∈x)"
proof -
  have eq: "{x∈A. a∈x} = Memrel(A∪{a}) `` {a}" for A
    unfolding ZF_Base.image_def
    by(intro equalityI,auto simp:mem_not_refl)
  moreover from assms
  have "M(Memrel(A∪{a}) `` {a})" if "M(A)" for A
    using that by simp
  ultimately
  show ?thesis
    using separation_iff Collect_abs
    by simp
qed

lemma lam_replacement_iff_lam_closed:
  assumes "∀x[M]. M(b(x))"
  shows "lam_replacement(M, b) ⟷  (∀A[M]. M(λx∈A. b(x)))"
  using assms lam_closed lam_funtype[of _ b, THEN Pi_memberD]
  unfolding lam_replacement_def strong_replacement_def
  by (auto intro:lamI dest:transM)
    (rule lam_closed, auto simp add:strong_replacement_def dest:transM)

lemma lam_replacement_imp_lam_closed:
  assumes "lam_replacement(M, b)" "M(A)" "∀x∈A. M(b(x))"
  shows "M(λx∈A. b(x))"
  using assms unfolding lam_replacement_def
  by (rule_tac lam_closed, auto simp add:strong_replacement_def dest:transM)

lemma lam_replacement_cong:
  assumes "lam_replacement(M,f)" "∀x[M]. f(x) = g(x)" "∀x[M]. M(f(x))"
  shows "lam_replacement(M,g)"
proof -
  note assms
  moreover from this
  have "∀A[M]. M(λx∈A. f(x))"
    using lam_replacement_iff_lam_closed
    by simp
  moreover from calculation
  have "(λx∈A . f(x)) = (λx∈A . g(x))" if "M(A)" for A
    using lam_cong[OF refl,of A f g] transM[OF _ that]
    by simp
  ultimately
  show ?thesis
    using lam_replacement_iff_lam_closed
    by simp
qed

lemma converse_subset : "converse(r) ⊆ {⟨snd(x),fst(x)⟩ . x∈r}"
  unfolding converse_def
proof(intro  subsetI, auto)
  fix u v
  assume "⟨u,v⟩∈r" (is "?z∈r")
  moreover
  have "v=snd(?z)" "u=fst(?z)" by simp_all
  ultimately
  show "∃z∈r. v=snd(z) ∧ u = fst(z)"
    using rexI[where x="⟨u,v⟩"] by force
qed

lemma converse_eq_aux :
  assumes "<0,0>∈r"
  shows "converse(r) = {⟨snd(x),fst(x)⟩ . x∈r}"
  using converse_subset
proof(intro equalityI subsetI,auto)
  fix z
  assume "z∈r"
  then show "⟨fst(z),snd(z)⟩ ∈ r"
  proof(cases "∃ a b . z =⟨a,b⟩")
    case True
    with ‹z∈r›
    show ?thesis by auto
  next
    case False
    then
    have "fst(z) = 0" "snd(z)=0"
      unfolding fst_def snd_def by auto
    with ‹z∈r› assms
    show ?thesis by auto
  qed
qed

lemma converse_eq_aux' :
  assumes "<0,0>∉r"
  shows "converse(r) = {⟨snd(x),fst(x)⟩ . x∈r} - {<0,0>}"
  using converse_subset assms
proof(intro equalityI subsetI,auto)
  fix z
  assume "z∈r" "snd(z)≠0"
  then
  obtain a b where "z = ⟨a,b⟩" unfolding snd_def by force
  with ‹z∈r›
  show "⟨fst(z),snd(z)⟩ ∈ r"
    by auto
next
  fix z
  assume "z∈r" "fst(z)≠0"
  then
  obtain a b where "z = ⟨a,b⟩" unfolding fst_def by force
  with ‹z∈r›
  show "⟨fst(z),snd(z)⟩ ∈ r"
    by auto
qed

lemma diff_un : "b⊆a ⟹ (a-b) ∪ b = a"
  by auto

lemma converse_eq: "converse(r) = ({⟨snd(x),fst(x)⟩ . x∈r} - {<0,0>}) ∪ (r∩{<0,0>})"
proof(cases "<0,0>∈r")
  case True
  then
  have "converse(r) = {⟨snd(x),fst(x)⟩ . x∈r}"
    using converse_eq_aux  by auto
  moreover
  from True
  have "r∩{<0,0>} = {<0,0>}" "{<0,0>}⊆{⟨snd(x),fst(x)⟩ . x∈r}"
    using converse_subset by auto
  moreover from this True
  have "{⟨snd(x),fst(x)⟩ . x∈r} = ({⟨snd(x),fst(x)⟩ . x∈r} - {<0,0>}) ∪ ({<0,0>})"
    using diff_un[of "{<0,0>}",symmetric] converse_eq_aux  by auto
  ultimately
  show ?thesis
    by simp
next
  case False
  then
  have "r∩{<0,0>} = 0" by auto
  then
  have "({⟨snd(x),fst(x)⟩ . x∈r} - {<0,0>}) ∪ (r∩{<0,0>}) = ({⟨snd(x),fst(x)⟩ . x∈r} - {<0,0>})"
    by simp
  with False
  show ?thesis
    using converse_eq_aux' by auto
qed

lemma range_subset : "range(r) ⊆ {snd(x). x∈r}"
  unfolding range_def domain_def converse_def
proof(intro  subsetI, auto)
  fix u v
  assume "⟨u,v⟩∈r" (is "?z∈r")
  moreover
  have "v=snd(?z)" "u=fst(?z)" by simp_all
  ultimately
  show "∃z∈r. v=snd(z)"
    using rexI[where x="v"] by force
qed

lemma lam_replacement_imp_strong_replacement_aux:
  assumes "lam_replacement(M, b)" "∀x[M]. M(b(x))"
  shows "strong_replacement(M, λx y. y = b(x))"
proof -
  {
    fix A
    note assms
    moreover
    assume "M(A)"
    moreover from calculation
    have "M(λx∈A. b(x))" using lam_replacement_iff_lam_closed by auto
    ultimately
    have "M((λx∈A. b(x))``A)" "∀z[M]. z ∈ (λx∈A. b(x))``A ⟷ (∃x∈A. z = b(x))"
      by (auto simp:lam_def)
  }
  then
  show ?thesis unfolding strong_replacement_def
    by clarsimp (rule_tac x="(λx∈A. b(x))``A" in rexI, auto)
qed

lemma lam_replacement_imp_RepFun_Lam:
  assumes "lam_replacement(M, f)" "M(A)"
  shows "M({y . x∈A , M(y) ∧ y=⟨x,f(x)⟩})"
proof -
  from assms
  obtain Y where 1:"M(Y)" "∀b[M]. b ∈ Y ⟷ (∃x[M]. x ∈ A ∧ b = ⟨x,f(x)⟩)"
    unfolding lam_replacement_def strong_replacement_def
    by auto
  moreover from calculation
  have "Y = {y . x∈A , M(y) ∧ y = ⟨x,f(x)⟩}" (is "Y=?R")
  proof(intro equalityI subsetI)
    fix y
    assume "y∈Y"
    moreover from this 1
    obtain x where "x∈A" "y=⟨x,f(x)⟩" "M(y)"
      using transM[OF _ ‹M(Y)›] by auto
    ultimately
    show "y∈?R"
      by auto
  next
    fix z
    assume "z∈?R"
    moreover from this
    obtain a where "a∈A" "z=⟨a,f(a)⟩" "M(a)" "M(f(a))"
      using transM[OF _ ‹M(A)›]
      by auto
    ultimately
    show "z∈Y" using 1 by simp
  qed
  ultimately
  show ?thesis by auto
qed

lemma lam_closed_imp_closed:
  assumes "∀A[M]. M(λx∈A. f(x))"
  shows "∀x[M]. M(f(x))"
proof
  fix x
  assume "M(x)"
  moreover from this and assms
  have "M(λx∈{x}. f(x))" by simp
  ultimately
  show "M(f(x))"
    using image_lam[of "{x}" "{x}" f]
      image_closed[of "{x}" "(λx∈{x}. f(x))"] by (auto dest:transM)
qed

lemma lam_replacement_if:
  assumes "lam_replacement(M,f)" "lam_replacement(M,g)" "separation(M,b)"
    "∀x[M]. M(f(x))" "∀x[M]. M(g(x))"
  shows "lam_replacement(M, λx. if b(x) then f(x) else g(x))"
proof -
  let ?G="λx. if b(x) then f(x) else g(x)"
  let ?b="λA . {x∈A. b(x)}" and ?b'="λA . {x∈A. ¬b(x)}"
  have eq:"(λx∈A . ?G(x)) = (λx∈?b(A) . f(x)) ∪ (λx∈?b'(A).g(x))" for A
    unfolding lam_def by auto
  have "?b'(A) = A - ?b(A)" for A by auto
  moreover
  have "M(?b(A))" if "M(A)" for A using assms that by simp
  moreover from calculation
  have "M(?b'(A))" if "M(A)" for A using that by simp
  moreover from calculation assms
  have "M(λx∈?b(A). f(x))" "M(λx∈?b'(A) . g(x))" if "M(A)" for A
    using lam_replacement_iff_lam_closed that
    by simp_all
  moreover from this
  have "M((λx∈?b(A) . f(x)) ∪ (λx∈?b'(A).g(x)))" if "M(A)" for A
    using that by simp
  ultimately
  have "M(λx∈A. if b(x) then f(x) else g(x))" if "M(A)" for A
    using that eq by simp
  with assms
  show ?thesis using lam_replacement_iff_lam_closed by simp
qed

lemma lam_replacement_constant: "M(b) ⟹ lam_replacement(M,λ_. b)"
  unfolding lam_replacement_def strong_replacement_def
  by safe (rule_tac x="_×{b}" in rexI; blast)

subsection‹Replacement instances obtained through Powerset›

txt‹The next few lemmas provide bounds for certain constructions.›

lemma not_functional_Replace_0:
  assumes "¬(∀y y'. P(y) ∧ P(y') ⟶ y=y')"
  shows "{y . x ∈ A, P(y)} = 0"
  using assms by (blast elim!: ReplaceE)

lemma Replace_in_Pow_rel:
  assumes "⋀x b. x ∈ A ⟹ P(x,b) ⟹ b ∈ U" "∀x∈A. ∀y y'. P(x,y) ∧ P(x,y') ⟶ y=y'"
    "separation(M, λy. ∃x[M]. x ∈ A ∧ P(x, y))"
    "M(U)" "M(A)"
  shows "{y . x ∈ A, P(x, y)} ∈ Pow⇗M⇖(U)"
proof -
  from assms
  have "{y . x ∈ A, P(x, y)} ⊆ U"
    "z ∈ {y . x ∈ A, P(x, y)} ⟹ M(z)" for z
    by (auto dest:transM)
  with assms
  have "{y . x ∈ A, P(x, y)} = {y∈U . ∃x[M]. x∈A ∧ P(x,y)}"
    by (intro equalityI) (auto, blast)
  with assms
  have "M({y . x ∈ A, P(x, y)})"
    by simp
  with assms
  show ?thesis
    using mem_Pow_rel_abs by auto
qed

lemma Replace_sing_0_in_Pow_rel:
  assumes "⋀b. P(b) ⟹ b ∈ U"
    "separation(M, λy. P(y))" "M(U)"
  shows "{y . x ∈ {0}, P(y)} ∈ Pow⇗M⇖(U)"
proof (cases "∀y y'. P(y) ∧ P(y') ⟶ y=y'")
  case True
  with assms
  show ?thesis by (rule_tac Replace_in_Pow_rel) auto
next
  case False
  with assms
  show ?thesis
    using nonempty not_functional_Replace_0[of P "{0}"] Pow_rel_char by auto
qed

lemma The_in_Pow_rel_Union:
  assumes "⋀b. P(b) ⟹ b ∈ U" "separation(M, λy. P(y))" "M(U)"
  shows "(THE i. P(i)) ∈ Pow⇗M⇖(⋃U)"
proof -
  note assms
  moreover from this
  have "(THE i. P(i)) ∈ Pow(⋃U)"
    unfolding the_def by auto
  moreover from assms
  have "M(THE i. P(i))"
    using Replace_sing_0_in_Pow_rel[of P U] unfolding the_def
    by (auto dest:transM)
  ultimately
  show ?thesis
    using Pow_rel_char by auto
qed

lemma separation_least: "separation(M, λy. Ord(y) ∧ P(y) ∧ (∀j. j < y ⟶ ¬ P(j)))"
  unfolding separation_def
proof
  fix z
  assume "M(z)"
  have "M({x ∈ z . x ∈ z ∧ Ord(x) ∧ P(x) ∧ (∀j. j < x ⟶ ¬ P(j))})"
    (is "M(?y)")
  proof (cases "∃x∈z. Ord(x) ∧ P(x) ∧ (∀j. j < x ⟶ ¬ P(j))")
    case True
    with ‹M(z)›
    have "∃x[M]. ?y = {x}"
      by (safe, rename_tac x, rule_tac x=x in rexI)
        (auto dest:transM, intro equalityI, auto elim:Ord_linear_lt)
    then
    show ?thesis
      by auto
  next
    case False
    then
    have "{x ∈ z . x ∈ z ∧ Ord(x) ∧ P(x) ∧ (∀j. j < x ⟶ ¬ P(j))} = 0"
      by auto
    then
    show ?thesis by auto
  qed
  moreover from this
  have "∀x[M]. x ∈ ?y ⟷ x ∈ z ∧ Ord(x) ∧ P(x) ∧ (∀j. j < x ⟶ ¬ P(j))" by simp
  ultimately
  show "∃y[M]. ∀x[M]. x ∈ y ⟷ x ∈ z ∧ Ord(x) ∧ P(x) ∧ (∀j. j < x ⟶ ¬ P(j))"
    by blast
qed

lemma Least_in_Pow_rel_Union:
  assumes "⋀b. P(b) ⟹ b ∈ U"
    "M(U)"
  shows "(μ i. P(i)) ∈ Pow⇗M⇖(⋃U)"
  using assms separation_least unfolding Least_def
  by (rule_tac The_in_Pow_rel_Union) simp

lemma bounded_lam_replacement:
  fixes U
  assumes "∀X[M]. ∀x∈X. f(x) ∈ U(X)"
    and separation_f:"∀A[M]. separation(M,λy. ∃x[M]. x∈A ∧ y = ⟨x, f(x)⟩)"
    and U_closed [intro,simp]: "⋀X. M(X) ⟹ M(U(X))"
  shows "lam_replacement(M, f)"
proof -
  have "M(λx∈A. f(x))" if "M(A)" for A
  proof -
    have "(λx∈A. f(x)) = {y∈ Pow⇗M⇖(Pow⇗M⇖(A ∪ U(A))). ∃x[M]. x∈A ∧ y = ⟨x, f(x)⟩}"
      using ‹M(A)› unfolding lam_def
    proof (intro equalityI, auto)
      fix x
      assume "x∈A"
      moreover
      note ‹M(A)›
      moreover from calculation assms
      have "f(x) ∈ U(A)" by simp
      moreover from calculation
      have "{x, f(x)} ∈ Pow⇗M⇖(A ∪ U(A))" "{x,x} ∈ Pow⇗M⇖(A ∪ U(A))"
        using Pow_rel_char[of "A ∪ U(A)"] by (auto dest:transM)
      ultimately
      show "⟨x, f(x)⟩ ∈ Pow⇗M⇖(Pow⇗M⇖(A ∪ U(A)))"
        using Pow_rel_char[of "Pow⇗M⇖(A ∪ U(A))"] unfolding Pair_def
        by (auto dest:transM)
    qed
    moreover from ‹M(A)›
    have "M({y∈ Pow⇗M⇖(Pow⇗M⇖(A ∪ U(A))). ∃x[M]. x∈A ∧ y = ⟨x, f(x)⟩})"
      using separation_f
      by (rule_tac separation_closed) simp_all
    ultimately
    show ?thesis
      by simp
  qed
  moreover from this
  have "∀x[M]. M(f(x))"
    using lam_closed_imp_closed by simp
  ultimately
  show ?thesis
    using assms
    by (rule_tac lam_replacement_iff_lam_closed[THEN iffD2]) simp_all
qed

lemma lam_replacement_domain':
  assumes "∀A[M]. separation(M, λy. ∃x∈A. y = ⟨x, domain(x)⟩)"
  shows "lam_replacement(M,domain)"
proof -
  have "∀x∈X. domain(x) ∈ Pow⇗M⇖(⋃⋃⋃X)" if "M(X)" for X
  proof
    fix x
    assume "x∈X"
    moreover
    note ‹M(X)›
    moreover from calculation
    have "M(x)" by (auto dest:transM)
    ultimately
    show "domain(x) ∈ Pow⇗M⇖(⋃⋃⋃X)"
      by(rule_tac mem_Pow_rel_abs[of "domain(x)" "⋃⋃⋃X",THEN iffD2],auto simp:Pair_def,force)
  qed
  with assms
  show ?thesis
    using bounded_lam_replacement[of domain "λX. Pow⇗M⇖(⋃⋃⋃X)"] by simp
qed

― ‹Below we assume the replacement instance for @{term fst}. Alternatively it follows from the
instance of separation assumed in this lemma.›
lemma lam_replacement_fst':
  assumes "∀A[M]. separation(M, λy. ∃x∈A. y = ⟨x, fst(x)⟩)"
  shows "lam_replacement(M,fst)"
proof -
  have "∀x∈X. fst(x) ∈ {0} ∪ ⋃⋃X" if "M(X)" for X
  proof
    fix x
    assume "x∈X"
    moreover
    note ‹M(X)›
    moreover from calculation
    have "M(x)" by (auto dest:transM)
    ultimately
    show "fst(x) ∈ {0} ∪ ⋃⋃X" unfolding fst_def Pair_def
      by (auto, rule_tac [1] the_0) force― ‹tricky! And slow. It doesn't work for term‹snd››
  qed
  with assms
  show ?thesis
    using bounded_lam_replacement[of fst "λX. {0} ∪ ⋃⋃X"] by simp
qed

lemma lam_replacement_restrict:
  assumes "∀A[M]. separation(M, λy. ∃x∈A. y = ⟨x, restrict(x,B)⟩)"  "M(B)"
  shows "lam_replacement(M, λr . restrict(r,B))"
proof -
  have "∀r∈R. restrict(r,B)∈Pow⇗M⇖(⋃R)" if "M(R)" for R
  proof -
    {
      fix r
      assume "r∈R"
      with ‹M(B)›
      have "restrict(r,B)∈Pow(⋃R)" "M(restrict(r,B))"
        using Union_upper subset_Pow_Union subset_trans[OF restrict_subset]
          transM[OF _ ‹M(R)›]
        by simp_all
    } then show ?thesis
      using Pow_rel_char that by simp
  qed
  with assms
  show ?thesis
    using bounded_lam_replacement[of "λr . restrict(r,B)" "λX. Pow⇗M⇖(⋃X)"]
    by simp
qed

end ― ‹locale‹M_basic››

locale M_replacement = M_basic +
  assumes
    lam_replacement_domain: "lam_replacement(M,domain)"
    and
    lam_replacement_fst: "lam_replacement(M,fst)"
    and
    lam_replacement_snd: "lam_replacement(M,snd)"
    and
    lam_replacement_Union: "lam_replacement(M,Union)"
    and
    middle_del_replacement: "strong_replacement(M, λx y. y=⟨fst(fst(x)),snd(snd(x))⟩)"
    and
    product_replacement:
    "strong_replacement(M, λx y. y=⟨snd(fst(x)),⟨fst(fst(x)),snd(snd(x))⟩⟩)"
    and
    lam_replacement_Upair:"lam_replacement(M, λp. Upair(fst(p),snd(p)))"
    and
    lam_replacement_Diff:"lam_replacement(M, λp. fst(p) - snd(p))"
    and
    lam_replacement_Image:"lam_replacement(M, λp. fst(p) `` snd(p))"
    and
    middle_separation: "separation(M, λx. snd(fst(x))=fst(snd(x)))"
    and
    separation_fst_in_snd: "separation(M, λy. fst(snd(y)) ∈ snd(snd(y)))"
    and
    lam_replacement_converse : "lam_replacement(M,converse)"
    and
    lam_replacement_comp: "lam_replacement(M, λx. fst(x) O snd(x))"
begin

lemma lam_replacement_imp_strong_replacement:
  assumes "lam_replacement(M, f)"
  shows "strong_replacement(M, λx y. y = f(x))"
proof -
  {
    fix A
    assume "M(A)"
    moreover from calculation assms
    obtain Y where 1:"M(Y)" "∀b[M]. b ∈ Y ⟷ (∃x[M]. x ∈ A ∧ b = ⟨x,f(x)⟩)"
      unfolding lam_replacement_def strong_replacement_def
      by auto
    moreover from this
    have "M({snd(b) . b ∈ Y})"
      using transM[OF _ ‹M(Y)›] lam_replacement_snd lam_replacement_imp_strong_replacement_aux
        RepFun_closed by simp
    moreover
    have "{snd(b) . b ∈ Y} = {y . x∈A , M(f(x)) ∧ y=f(x)}" (is "?L=?R")
    proof(intro equalityI subsetI)
      fix x
      assume "x∈?L"
      moreover from this
      obtain b where "b∈Y" "x=snd(b)" "M(b)"
        using transM[OF _ ‹M(Y)›] by auto
      moreover from this 1
      obtain a where "a∈A" "b=⟨a,f(a)⟩" by auto
      moreover from calculation
      have "x=f(a)" by simp
      ultimately show "x∈?R"
        by auto
    next
      fix z
      assume "z∈?R"
      moreover from this
      obtain a where "a∈A" "z=f(a)" "M(a)" "M(f(a))"
        using transM[OF _ ‹M(A)›]
        by auto
      moreover from calculation this 1
      have "z=snd(⟨a,f(a)⟩)" "⟨a,f(a)⟩ ∈ Y" by auto
      ultimately
      show "z∈?L" by force
    qed
    ultimately
    have "∃Z[M]. ∀z[M]. z∈Z ⟷ (∃a[M]. a∈A ∧ z=f(a))"
      by (rule_tac rexI[where x="{snd(b) . b ∈ Y}"],auto)
  }
  then
  show ?thesis unfolding strong_replacement_def by simp
qed

lemma Collect_middle: "{p ∈ (λx∈A. f(x)) × (λx∈{f(x) . x∈A}. g(x)) . snd(fst(p))=fst(snd(p))}
     = { ⟨⟨x,f(x)⟩,⟨f(x),g(f(x))⟩⟩ . x∈A }"
  by (intro equalityI; auto simp:lam_def)

lemma RepFun_middle_del: "{ ⟨fst(fst(p)),snd(snd(p))⟩ . p ∈ { ⟨⟨x,f(x)⟩,⟨f(x),g(f(x))⟩⟩ . x∈A }}
        =  { ⟨x,g(f(x))⟩ . x∈A }"
  by auto

lemma lam_replacement_imp_RepFun:
  assumes "lam_replacement(M, f)" "M(A)"
  shows "M({y . x∈A , M(y) ∧ y=f(x)})"
proof -
  from assms
  obtain Y where 1:"M(Y)" "∀b[M]. b ∈ Y ⟷ (∃x[M]. x ∈ A ∧ b = ⟨x,f(x)⟩)"
    unfolding lam_replacement_def strong_replacement_def
    by auto
  moreover from this
  have "M({snd(b) . b ∈ Y})"
    using transM[OF _ ‹M(Y)›] lam_replacement_snd lam_replacement_imp_strong_replacement_aux
      RepFun_closed by simp
  moreover
  have "{snd(b) . b ∈ Y} = {y . x∈A , M(y) ∧ y=f(x)}" (is "?L=?R")
  proof(intro equalityI subsetI)
    fix x
    assume "x∈?L"
    moreover from this
    obtain b where "b∈Y" "x=snd(b)" "M(b)"
      using transM[OF _ ‹M(Y)›] by auto
    moreover from this 1
    obtain a where "a∈A" "b=⟨a,f(a)⟩" by auto
    moreover from calculation
    have "x=f(a)" by simp
    ultimately show "x∈?R"
      by auto
  next
    fix z
    assume "z∈?R"
    moreover from this
    obtain a where "a∈A" "z=f(a)" "M(a)" "M(f(a))"
      using transM[OF _ ‹M(A)›]
      by auto
    moreover from calculation this 1
    have "z=snd(⟨a,f(a)⟩)" "⟨a,f(a)⟩ ∈ Y" by auto
    ultimately
    show "z∈?L" by force
  qed
  ultimately
  show ?thesis by simp
qed

lemma lam_replacement_product:
  assumes "lam_replacement(M,f)" "lam_replacement(M,g)"
  shows "lam_replacement(M, λx. ⟨f(x),g(x)⟩)"
proof -
  {
    fix A
    let ?Y="{y . x∈A , M(y) ∧ y=f(x)}"
    let ?Y'="{y . x∈A ,M(y) ∧  y=⟨x,f(x)⟩}"
    let ?Z="{y . x∈A , M(y) ∧ y=g(x)}"
    let ?Z'="{y . x∈A ,M(y) ∧  y=⟨x,g(x)⟩}"
    have "x∈C ⟹ y∈C ⟹ fst(x) = fst(y) ⟶ M(fst(y)) ∧ M(snd(x)) ∧ M(snd(y))" if "M(C)" for C y x
      using transM[OF _ that] by auto
    moreover
    note assms
    moreover
    assume "M(A)"
    moreover from ‹M(A)› assms(1)
    have "M(converse(?Y'))" "M(?Y)"
      using lam_replacement_imp_RepFun_Lam lam_replacement_imp_RepFun by auto
    moreover from calculation
    have "M(?Z)" "M(?Z')"
      using lam_replacement_imp_RepFun_Lam lam_replacement_imp_RepFun by auto
    moreover from calculation
    have "M(converse(?Y')×?Z')"
      by simp
    moreover from this
    have "M({p ∈ converse(?Y')×?Z' . snd(fst(p))=fst(snd(p))})" (is "M(?P)")
      using middle_separation by simp
    moreover from calculation
    have "M({ ⟨snd(fst(p)),⟨fst(fst(p)),snd(snd(p))⟩⟩ . p∈?P })" (is "M(?R)")
      using RepFun_closed[OF product_replacement ‹M(?P)› ] by simp
    ultimately
    have "b ∈ ?R ⟷ (∃x[M]. x ∈ A ∧ b = ⟨x,⟨f(x),g(x)⟩⟩)" if "M(b)" for b
      using that
      apply(intro iffI)apply(auto)[1]
    proof -
      assume " ∃x[M]. x ∈ A ∧ b = ⟨x, f(x), g(x)⟩"
      moreover from this
      obtain x where "M(x)" "x∈A" "b= ⟨x, ⟨f(x), g(x)⟩⟩"
        by auto
      moreover from calculation that
      have "M(⟨x,f(x)⟩)" "M(⟨x,g(x)⟩)" by auto
      moreover from calculation
      have "⟨f(x),x⟩ ∈ converse(?Y')" "⟨x,g(x)⟩ ∈ ?Z'" by auto
      moreover from calculation
      have "⟨⟨f(x),x⟩,⟨x,g(x)⟩⟩∈converse(?Y')×?Z'" by auto
      moreover from calculation
      have "⟨⟨f(x),x⟩,⟨x,g(x)⟩⟩ ∈ ?P"
        (is "?p∈?P")
        by auto
      moreover from calculation
      have "b = ⟨snd(fst(?p)),⟨fst(fst(?p)),snd(snd(?p))⟩⟩" by auto
      moreover from calculation
      have "⟨snd(fst(?p)),⟨fst(fst(?p)),snd(snd(?p))⟩⟩∈?R"
        by(rule_tac RepFunI[of ?p ?P], simp)
      ultimately show "b∈?R" by simp
    qed
    with ‹M(?R)›
    have "∃Y[M]. ∀b[M]. b ∈ Y ⟷ (∃x[M]. x ∈ A ∧ b = ⟨x,⟨f(x),g(x)⟩⟩)"
      by (rule_tac rexI[where x="?R"],simp_all)
  }
  with assms
  show ?thesis using lam_replacement_def strong_replacement_def by simp
qed

lemma lam_replacement_hcomp:
  assumes "lam_replacement(M,f)" "lam_replacement(M,g)" "∀x[M]. M(f(x))"
  shows "lam_replacement(M, λx. g(f(x)))"
proof -
  {
    fix A
    let ?Y="{y . x∈A , y=f(x)}"
    let ?Y'="{y . x∈A , y=⟨x,f(x)⟩}"
    have "∀x∈C. M(⟨fst(fst(x)),snd(snd(x))⟩)" if "M(C)" for C
      using transM[OF _ that] by auto
    moreover
    note assms
    moreover
    assume "M(A)"
    moreover from assms
    have eq:"?Y = {y . x∈A ,M(y) ∧ y=f(x)}"  "?Y' = {y . x∈A ,M(y) ∧ y=⟨x,f(x)⟩}"
      using transM[OF _ ‹M(A)›] by auto
    moreover from ‹M(A)› assms(1)
    have "M(?Y')" "M(?Y)"
      using lam_replacement_imp_RepFun_Lam lam_replacement_imp_RepFun eq by auto
    moreover from calculation
    have "M({z . y∈?Y , M(z) ∧ z=⟨y,g(y)⟩})" (is "M(?Z)")
      using lam_replacement_imp_RepFun_Lam by auto
    moreover from calculation
    have "M(?Y'×?Z)"
      by simp
    moreover from this
    have "M({p ∈ ?Y'×?Z . snd(fst(p))=fst(snd(p))})" (is "M(?P)")
      using middle_separation by simp
    moreover from calculation
    have "M({ ⟨fst(fst(p)),snd(snd(p))⟩ . p∈?P })" (is "M(?R)")
      using RepFun_closed[OF middle_del_replacement ‹M(?P)›] by simp
    ultimately
    have "b ∈ ?R ⟷ (∃x[M]. x ∈ A ∧ b = ⟨x,g(f(x))⟩)" if "M(b)" for b
      using that assms(3)
      apply(intro iffI) apply(auto)[1]
    proof -
      assume "∃x[M]. x ∈ A ∧ b = ⟨x, g(f(x))⟩"
      moreover from this
      obtain x where "M(x)" "x∈A" "b= ⟨x, g(f(x))⟩"
        by auto
      moreover from calculation that assms(3)
      have "M(f(x))" "M(g(f(x)))" by auto
      moreover from calculation
      have "⟨x,f(x)⟩ ∈ ?Y'" by auto
      moreover from calculation
      have "⟨f(x),g(f(x))⟩∈?Z" by auto
      moreover from calculation
      have "⟨⟨x,f(x)⟩,⟨f(x),g(f(x))⟩⟩ ∈ ?P"
        (is "?p∈?P")
        by auto
      moreover from calculation
      have "b = ⟨fst(fst(?p)),snd(snd(?p))⟩" by auto
      moreover from calculation
      have "⟨fst(fst(?p)),snd(snd(?p))⟩∈?R"
        by(rule_tac RepFunI[of ?p ?P], simp)
      ultimately show "b∈?R" by simp
    qed
    with ‹M(?R)›
    have "∃Y[M]. ∀b[M]. b ∈ Y ⟷ (∃x[M]. x ∈ A ∧ b = ⟨x,g(f(x))⟩)"
      by (rule_tac rexI[where x="?R"],simp_all)
  }
  with assms
  show ?thesis using lam_replacement_def strong_replacement_def by simp
qed

lemma lam_replacement_Collect :
  assumes "M(A)" "∀x[M]. separation(M,F(x))"
    "separation(M,λp . ∀x∈A. x∈snd(p) ⟷ F(fst(p),x))"
  shows "lam_replacement(M,λx. {y∈A . F(x,y)})"
proof -
  {
    fix Z
    let ?Y="λz.{x∈A . F(z,x)}"
    assume "M(Z)"
    moreover from this
    have "M(?Y(z))" if "z∈Z" for z
      using assms that transM[of _ Z] by simp
    moreover from this
    have "?Y(z)∈Pow⇗M⇖(A)" if "z∈Z" for z
      using Pow_rel_char that assms by auto
    moreover from calculation ‹M(A)›
    have "M(Z×Pow⇗M⇖(A))" by simp
    moreover from this
    have "M({p ∈ Z×Pow⇗M⇖(A) . ∀x∈A. x∈snd(p) ⟷ F(fst(p),x)})" (is "M(?P)")
      using assms by simp
    ultimately
    have "b ∈ ?P ⟷ (∃z[M]. z∈Z ∧ b=⟨z,?Y(z)⟩)" if "M(b)" for b
      using  assms(1) Pow_rel_char[OF ‹M(A)›] that
      by(intro iffI,auto,intro equalityI,auto)
    with ‹M(?P)›
    have "∃Y[M]. ∀b[M]. b ∈ Y ⟷ (∃z[M]. z ∈ Z ∧ b = ⟨z,?Y(z)⟩)"
      by (rule_tac rexI[where x="?P"],simp_all)
  }
  then
  show ?thesis
    unfolding lam_replacement_def strong_replacement_def
    by simp
qed

lemma lam_replacement_hcomp2:
  assumes "lam_replacement(M,f)" "lam_replacement(M,g)"
    "∀x[M]. M(f(x))" "∀x[M]. M(g(x))"
    "lam_replacement(M, λp. h(fst(p),snd(p)))"
    "∀x[M]. ∀y[M]. M(h(x,y))"
  shows "lam_replacement(M, λx. h(f(x),g(x)))"
  using assms lam_replacement_product[of f g]
    lam_replacement_hcomp[of "λx. ⟨f(x), g(x)⟩" "λ⟨x,y⟩. h(x,y)"]
  unfolding split_def by simp

lemma lam_replacement_identity: "lam_replacement(M,λx. x)"
proof -
  {
    fix A
    assume "M(A)"
    moreover from this
    have "id(A) = {⟨snd(fst(z)),fst(snd(z))⟩ . z∈ {z∈ (A×A)×(A×A). snd(fst(z)) = fst(snd(z))}}"
      unfolding id_def lam_def
      by(intro equalityI subsetI,simp_all,auto)
    moreover from calculation
    have "M({z∈ (A×A)×(A×A). snd(fst(z)) = fst(snd(z))})" (is "M(?A')")
      using middle_separation by simp
    moreover from calculation
    have "M({⟨snd(fst(z)),fst(snd(z))⟩ . z∈ ?A'})"
      using transM[of _ A]
        lam_replacement_product lam_replacement_hcomp lam_replacement_fst lam_replacement_snd
        lam_replacement_imp_strong_replacement[THEN RepFun_closed]
      by simp_all
    ultimately
    have "M(id(A))" by simp
  }
  then
  show ?thesis using lam_replacement_iff_lam_closed
    unfolding id_def by simp
qed

lemma lam_replacement_vimage :
  shows "lam_replacement(M, λx. fst(x)-``snd(x))"
  unfolding vimage_def using
    lam_replacement_hcomp2[OF
      lam_replacement_hcomp[OF lam_replacement_fst lam_replacement_converse] lam_replacement_snd
      _ _ lam_replacement_Image]
  by auto

lemma strong_replacement_separation_aux :
  assumes "strong_replacement(M,λ x y . y=f(x))" "separation(M,P)"
  shows "strong_replacement(M, λx y . P(x) ∧ y=f(x))"
proof -
  {
    fix A
    let ?Q="λX. ∀b[M]. b ∈ X ⟷ (∃x[M]. x ∈ A ∧ P(x) ∧ b = f(x))"
    assume "M(A)"
    moreover from this
    have "M({x∈A . P(x)})" (is "M(?B)") using assms by simp
    moreover from calculation assms
    obtain Y where "M(Y)" "∀b[M]. b ∈ Y ⟷ (∃x[M]. x ∈ ?B ∧ b = f(x))"
      unfolding strong_replacement_def by auto
    then
    have "∃Y[M]. ∀b[M]. b ∈ Y ⟷ (∃x[M]. x ∈ A ∧ P(x) ∧ b = f(x))"
      using rexI[of ?Q _ M] by simp
  }
  then
  show ?thesis
    unfolding strong_replacement_def by simp
qed

lemma separation_in:
  assumes "∀x[M]. M(f(x))" "lam_replacement(M,f)"
    "∀x[M]. M(g(x))" "lam_replacement(M,g)"
  shows "separation(M,λx . f(x)∈g(x))"
proof -
  let ?Z="λA. {⟨x,⟨f(x),g(x)⟩⟩. x∈A}"
  have "M(?Z(A))" if "M(A)" for A
    using assms lam_replacement_iff_lam_closed that
      lam_replacement_product[of f g]
    unfolding lam_def
    by auto
  then
  have "M({u∈?Z(A) . fst(snd(u)) ∈snd(snd(u))})" (is "M(?W(A))") if "M(A)" for A
    using that separation_fst_in_snd assms
    by auto
  then
  have "M({fst(u) . u ∈ ?W(A)})" if "M(A)" for A
    using that lam_replacement_imp_strong_replacement[OF lam_replacement_fst,THEN
        RepFun_closed] fst_closed[OF transM]
    by auto
  moreover
  have "{x∈A. f(x)∈g(x)} = {fst(u) . u∈?W(A)}" for A
    by auto
  ultimately
  show ?thesis
    using separation_iff
    by auto
qed

lemma lam_replacement_swap: "lam_replacement(M, λx. ⟨snd(x),fst(x)⟩)"
  using lam_replacement_fst lam_replacement_snd
    lam_replacement_product[of "snd" "fst"] by simp

lemma lam_replacement_range : "lam_replacement(M,range)"
  unfolding range_def
  using lam_replacement_hcomp[OF lam_replacement_converse lam_replacement_domain]
  by auto

lemma separation_in_range : "M(a) ⟹ separation(M, λx. a∈range(x))"
  using lam_replacement_range lam_replacement_constant separation_in
  by auto

lemma separation_in_domain : "M(a) ⟹ separation(M, λx. a∈domain(x))"
  using lam_replacement_domain lam_replacement_constant separation_in
  by auto

lemma lam_replacement_separation :
  assumes "lam_replacement(M,f)" "separation(M,P)"
  shows "strong_replacement(M, λx y . P(x) ∧ y=⟨x,f(x)⟩)"
  using strong_replacement_separation_aux assms
  unfolding lam_replacement_def
  by simp

lemmas strong_replacement_separation =
  strong_replacement_separation_aux[OF lam_replacement_imp_strong_replacement]

lemma id_closed: "M(A) ⟹ M(id(A))"
  using lam_replacement_identity lam_replacement_iff_lam_closed
  unfolding id_def by simp

lemma relation_separation: "separation(M, λz. ∃x y. z = ⟨x, y⟩)"
  unfolding separation_def
proof (clarify)
  fix A
  assume "M(A)"
  moreover from this
  have "{z∈A. ∃x y. z = ⟨x, y⟩} = {z∈A. ∃x∈domain(A). ∃y∈range(A). pair(M, x, y, z)}"
    (is "?rel = _")
    by (intro equalityI, auto dest:transM)
      (intro bexI, auto dest:transM simp:Pair_def)
  moreover from calculation
  have "M(?rel)"
    using cartprod_separation[THEN separation_closed, of "domain(A)" "range(A)" A]
    by simp
  ultimately
  show "∃y[M]. ∀x[M]. x ∈ y ⟷ x ∈ A ∧ (∃w y. x = ⟨w, y⟩)"
    by (rule_tac x="{z∈A. ∃x y. z = ⟨x, y⟩}" in rexI) auto
qed

lemma separation_pair:
  assumes "separation(M, λy . P(fst(y), snd(y)))"
  shows "separation(M, λy. ∃ u v . y=⟨u,v⟩ ∧ P(u,v))"
  unfolding separation_def
proof(clarify)
  fix A
  assume "M(A)"
  moreover from this
  have "M({z∈A. ∃x y. z = ⟨x, y⟩})" (is "M(?P)")
    using relation_separation by simp
  moreover from this assms
  have "M({z∈?P . P(fst(z),snd(z))})"
    by(rule_tac separation_closed,simp_all)
  moreover
  have "{y∈A . ∃ u v . y=⟨u,v⟩ ∧ P(u,v) } = {z∈?P . P(fst(z),snd(z))}"
    by(rule equalityI subsetI,auto)
  moreover from calculation
  have "M({y∈A . ∃ u v . y=⟨u,v⟩ ∧ P(u,v) })"
    by simp
  ultimately
  show "∃y[M]. ∀x[M]. x ∈ y ⟷ x ∈ A ∧ (∃w y. x = ⟨w, y⟩ ∧ P(w,y))"
    by (rule_tac x="{z∈A. ∃x y. z = ⟨x, y⟩ ∧ P(x,y)}" in rexI) auto
qed

lemma lam_replacement_Pair:
  shows "lam_replacement(M, λx. ⟨fst(x), snd(x)⟩)"
  unfolding lam_replacement_def strong_replacement_def
proof (clarsimp)
  fix A
  assume "M(A)"
  then
  show "∃Y[M]. ∀b[M]. b ∈ Y ⟷ (∃x∈A. b = ⟨x, fst(x), snd(x)⟩)"
    unfolding lam_replacement_def strong_replacement_def
  proof (cases "relation(A)")
    case True
    with ‹M(A)›
    show ?thesis
      using id_closed unfolding relation_def
      by (rule_tac x="id(A)" in rexI) auto
  next
    case False
    moreover
    note ‹M(A)›
    moreover from this
    have "M({z∈A. ∃x y. z = ⟨x, y⟩})" (is "M(?rel)")
      using relation_separation by auto
    moreover
    have "z = ⟨fst(z), snd(z)⟩" if "fst(z) ≠ 0 ∨ snd(z) ≠ 0" for z
      using that
      by (cases "∃a b. z=⟨a,b⟩") (auto simp add: the_0 fst_def snd_def)
    ultimately
    show ?thesis
      using id_closed unfolding relation_def
      by (rule_tac x="id(?rel) ∪ (A-?rel)×{0}×{0}" in rexI)
        (force simp:fst_def snd_def)+
  qed
qed

lemma lam_replacement_Un: "lam_replacement(M, λp. fst(p) ∪ snd(p))"
  using lam_replacement_Upair lam_replacement_Union
    lam_replacement_hcomp[where g=Union and f="λp. Upair(fst(p),snd(p))"]
  unfolding Un_def by simp

lemma lam_replacement_cons: "lam_replacement(M, λp. cons(fst(p),snd(p)))"
  using  lam_replacement_Upair
    lam_replacement_hcomp2[of _ _ "(∪)"]
    lam_replacement_hcomp2[of fst fst "Upair"]
    lam_replacement_Un lam_replacement_fst lam_replacement_snd
  unfolding cons_def
  by auto

lemma lam_replacement_sing: "lam_replacement(M, λx. {x})"
  using lam_replacement_constant lam_replacement_cons
    lam_replacement_hcomp2[of "λx. x" "λ_. 0" cons]
  by (force intro: lam_replacement_identity)

lemmas tag_replacement = lam_replacement_constant[unfolded lam_replacement_def]

lemma lam_replacement_id2: "lam_replacement(M, λx. ⟨x, x⟩)"
  using lam_replacement_identity lam_replacement_product[of "λx. x" "λx. x"]
  by simp

lemmas id_replacement = lam_replacement_id2[unfolded lam_replacement_def]

lemma lam_replacement_apply2:"lam_replacement(M, λp. fst(p) ` snd(p))"
  using lam_replacement_sing lam_replacement_fst lam_replacement_snd
    lam_replacement_Image lam_replacement_Union
  unfolding apply_def
  by (rule_tac lam_replacement_hcomp[of _ Union],
      rule_tac lam_replacement_hcomp2[of _ _ "(``)"])
    (force intro:lam_replacement_hcomp)+

definition map_snd where
  "map_snd(X) = {snd(z) . z∈X}"

lemma map_sndE: "y∈map_snd(X) ⟹ ∃p∈X. y=snd(p)"
  unfolding map_snd_def by auto

lemma map_sndI : "∃p∈X. y=snd(p) ⟹ y∈map_snd(X)"
  unfolding map_snd_def by auto

lemma map_snd_closed: "M(x) ⟹ M(map_snd(x))"
  unfolding map_snd_def
  using lam_replacement_imp_strong_replacement[OF lam_replacement_snd]
    RepFun_closed snd_closed[OF transM[of _ x]]
  by simp

lemma lam_replacement_imp_lam_replacement_RepFun:
  assumes "lam_replacement(M, f)" "∀x[M]. M(f(x))"
    "separation(M, λx. ((∀y∈snd(x). fst(y) ∈ fst(x)) ∧ (∀y∈fst(x). ∃u∈snd(x). y=fst(u))))"
    and
    lam_replacement_RepFun_snd:"lam_replacement(M,map_snd)"
  shows "lam_replacement(M, λx. {f(y) . y∈x})"
proof -
  have f_closed:"M(⟨fst(z),map_snd(snd(z))⟩)" if "M(z)" for z
    using pair_in_M_iff fst_closed snd_closed map_snd_closed that
    by simp
  have p_closed:"M(⟨x,{f(y) . y∈x}⟩)" if "M(x)" for x
    using pair_in_M_iff RepFun_closed lam_replacement_imp_strong_replacement
      transM[OF _ that] that assms by auto
  {
    fix A
    assume "M(A)"
    then
    have "M({⟨y,f(y)⟩ . y∈x})" if "x∈A" for x
      using lam_replacement_iff_lam_closed assms that transM[of _ A]
      unfolding lam_def by simp
    from assms ‹M(A)›
    have "∀x∈⋃A. M(f(x))"
      using transM[of _ "⋃A"] by auto
    with assms ‹M(A)›
    have "M({⟨y,f(y)⟩ . y ∈ ⋃A})" (is "M(?fUnA)")
      using lam_replacement_iff_lam_closed[THEN iffD1,OF assms(2) assms(1)]
      unfolding lam_def
      by simp
    with ‹M(A)›
    have "M(Pow_rel(M,?fUnA))" by simp
    with ‹M(A)›
    have "M({z∈A×Pow_rel(M,?fUnA) . ((∀y∈snd(z). fst(y) ∈ fst(z)) ∧ (∀y∈fst(z). ∃u∈snd(z). y=fst(u)))})" (is "M(?T)")
      using assms(3) by simp
    then
    have 1:"M({⟨fst(z),map_snd(snd(z))⟩ . z∈?T})" (is "M(?Y)")
      using lam_replacement_product[OF lam_replacement_fst
          lam_replacement_hcomp[OF lam_replacement_snd lam_replacement_RepFun_snd]]
        RepFun_closed lam_replacement_imp_strong_replacement
        f_closed[OF transM[OF _ ‹M(?T)›]]
      by simp
    have 2:"?Y = {⟨x,{f(y) . y∈x}⟩ . x∈A}" (is "_ = ?R")
    proof(intro equalityI subsetI)
      fix p
      assume "p∈?R"
      with ‹M(A)›
      obtain x where "x∈A" "p=⟨x,{f(y) . y ∈ x}⟩" "M(x)"
        using transM[OF _ ‹M(A)›]
        by auto
      moreover from calculation
      have "M({⟨y,f(y)⟩ . y∈x})" (is "M(?Ux)")
        using lam_replacement_iff_lam_closed assms
        unfolding lam_def by auto
      moreover from calculation
      have "?Ux ⊆ ?fUnA"
        by auto
      moreover from calculation
      have "?Ux ∈ Pow_rel(M,?fUnA)"
        using Pow_rel_char[OF ‹M(?fUnA)›] by simp
      moreover from calculation
      have "∀u∈x. ∃w∈?Ux. u=fst(w)"
        by force
      moreover from calculation
      have "⟨x,?Ux⟩ ∈ ?T" by auto
      moreover from calculation
      have "{f(y).y∈x} = map_snd(?Ux)"
        unfolding map_snd_def
        by(intro equalityI,auto)
      ultimately
      show "p∈?Y"
        by (auto,rule_tac bexI[where x=x],simp_all,rule_tac bexI[where x="?Ux"],simp_all)
    next
      fix u
      assume "u∈?Y"
      moreover from this
      obtain z where "z∈?T" "u=⟨fst(z),map_snd(snd(z))⟩"
        by blast
      moreover from calculation
      obtain x U where
        1:"x∈A" "U∈Pow_rel(M,?fUnA)" "(∀u∈U. fst(u) ∈ x) ∧ (∀w∈x. ∃v∈U. w=fst(v))" "z=⟨x,U⟩"
        by force
      moreover from this
      have "fst(u)∈⋃A" "snd(u) = f(fst(u))" if "u∈U" for u
        using that Pow_rel_char[OF ‹M(?fUnA)›]
        by auto
      moreover from calculation
      have "map_snd(U) = {f(y) . y∈x}"
        unfolding map_snd_def
        by(intro equalityI subsetI,auto)
      moreover from calculation
      have "u=⟨x,map_snd(U)⟩"
        by simp
      ultimately
      show "u∈?R"
        by (auto)
    qed
    from 1 2
    have "M({⟨x,{f(y) . y∈x}⟩ . x∈A})"
      by simp
  }
  then
  have "∀A[M]. M(λx∈A. {f(y) . y∈x})"
    unfolding lam_def by auto
  then
  show ?thesis
    using lam_replacement_iff_lam_closed[THEN iffD2] p_closed
    by simp
qed


lemma lam_replacement_apply:"M(S) ⟹ lam_replacement(M, λx.  S ` x)"
  using lam_replacement_Union lam_replacement_constant lam_replacement_identity
    lam_replacement_Image lam_replacement_cons
    lam_replacement_hcomp2[of _ _ Image] lam_replacement_hcomp2[of "λx. x" "λ_. 0" cons]
  unfolding apply_def
  by (rule_tac lam_replacement_hcomp[of _ Union]) (force intro:lam_replacement_hcomp)+

lemma apply_replacement:"M(S) ⟹ strong_replacement(M, λx y. y = S ` x)"
  using lam_replacement_apply lam_replacement_imp_strong_replacement by simp

lemma lam_replacement_id_const: "M(b) ⟹ lam_replacement(M, λx. ⟨x, b⟩)"
  using lam_replacement_identity lam_replacement_constant
    lam_replacement_product[of "λx. x" "λx. b"] by simp

lemmas pospend_replacement = lam_replacement_id_const[unfolded lam_replacement_def]

lemma lam_replacement_const_id: "M(b) ⟹ lam_replacement(M, λz. ⟨b, z⟩)"
  using lam_replacement_identity lam_replacement_constant
    lam_replacement_product[of "λx. b" "λx. x"] by simp

lemmas prepend_replacement = lam_replacement_const_id[unfolded lam_replacement_def]

lemma lam_replacement_apply_const_id: "M(f) ⟹ M(z) ⟹
      lam_replacement(M, λx. f ` ⟨z, x⟩)"
  using lam_replacement_const_id[of z] lam_replacement_apply[of f]
    lam_replacement_hcomp[of "λx. ⟨z, x⟩" "λx. f`x"] by simp

lemmas apply_replacement2 = lam_replacement_apply_const_id[unfolded lam_replacement_def]

lemma lam_replacement_Inl: "lam_replacement(M, Inl)"
  using lam_replacement_identity lam_replacement_constant
    lam_replacement_product[of "λx. 0" "λx. x"]
  unfolding Inl_def by simp

lemma lam_replacement_Inr: "lam_replacement(M, Inr)"
  using lam_replacement_identity lam_replacement_constant
    lam_replacement_product[of "λx. 1" "λx. x"]
  unfolding Inr_def by simp

lemmas Inl_replacement1 = lam_replacement_Inl[unfolded lam_replacement_def]

lemma lam_replacement_Diff': "M(X) ⟹ lam_replacement(M, λx. x - X)"
  using lam_replacement_Diff
  by (force intro: lam_replacement_hcomp2 lam_replacement_constant
      lam_replacement_identity)+

lemmas Pair_diff_replacement = lam_replacement_Diff'[unfolded lam_replacement_def]

lemma diff_Pair_replacement: "M(p) ⟹ strong_replacement(M, λx y . y=⟨x,x-{p}⟩)"
  using Pair_diff_replacement by simp

lemma swap_replacement:"strong_replacement(M, λx y. y = ⟨x, (λ⟨x,y⟩. ⟨y, x⟩)(x)⟩)"
  using lam_replacement_swap unfolding lam_replacement_def split_def by simp

lemma lam_replacement_Un_const:"M(b) ⟹ lam_replacement(M, λx. x ∪ b)"
  using lam_replacement_Un lam_replacement_hcomp2[of _ _ "(∪)"]
    lam_replacement_constant[of b] lam_replacement_identity by simp

lemmas tag_union_replacement = lam_replacement_Un_const[unfolded lam_replacement_def]

lemma lam_replacement_csquare: "lam_replacement(M,λp. ⟨fst(p) ∪ snd(p), fst(p), snd(p)⟩)"
  using lam_replacement_Un lam_replacement_fst lam_replacement_snd
  by (fast intro: lam_replacement_product lam_replacement_hcomp2)

lemma csquare_lam_replacement:"strong_replacement(M, λx y. y = ⟨x, (λ⟨x,y⟩. ⟨x ∪ y, x, y⟩)(x)⟩)"
  using lam_replacement_csquare unfolding split_def lam_replacement_def .

lemma lam_replacement_assoc:"lam_replacement(M,λx. ⟨fst(fst(x)), snd(fst(x)), snd(x)⟩)"
  using lam_replacement_fst lam_replacement_snd
  by (force intro: lam_replacement_product lam_replacement_hcomp)

lemma assoc_replacement:"strong_replacement(M, λx y. y = ⟨x, (λ⟨⟨x,y⟩,z⟩. ⟨x, y, z⟩)(x)⟩)"
  using lam_replacement_assoc unfolding split_def lam_replacement_def .

lemma lam_replacement_prod_fun: "M(f) ⟹ M(g) ⟹ lam_replacement(M,λx. ⟨f ` fst(x), g ` snd(x)⟩)"
  using lam_replacement_fst lam_replacement_snd
  by (force intro: lam_replacement_product lam_replacement_hcomp lam_replacement_apply)

lemma prod_fun_replacement:"M(f) ⟹ M(g) ⟹
  strong_replacement(M, λx y. y = ⟨x, (λ⟨w,y⟩. ⟨f ` w, g ` y⟩)(x)⟩)"
  using lam_replacement_prod_fun unfolding split_def lam_replacement_def .

lemma lam_replacement_vimage_sing: "lam_replacement(M, λp. fst(p) -`` {snd(p)})"
  using lam_replacement_hcomp[OF lam_replacement_snd lam_replacement_sing]
    lam_replacement_hcomp2[OF lam_replacement_fst  _ _ _ lam_replacement_vimage]
  by simp

lemma lam_replacement_vimage_sing_fun: "M(f) ⟹ lam_replacement(M, λx. f -`` {x})"
  using lam_replacement_hcomp2[OF lam_replacement_constant[of f]
      lam_replacement_identity _ _ lam_replacement_vimage_sing]
  by simp
lemma lam_replacement_image_sing_fun: "M(f) ⟹ lam_replacement(M, λx. f `` {x})"
  using lam_replacement_hcomp2[OF lam_replacement_constant[of f]
      lam_replacement_hcomp[OF lam_replacement_identity lam_replacement_sing]
      _ _ lam_replacement_Image]
  by simp

lemma converse_apply_projs: "∀x[M]. ⋃ (fst(x) -`` {snd(x)}) = converse(fst(x)) ` (snd(x))"
  using converse_apply_eq by auto

lemma lam_replacement_converse_app: "lam_replacement(M, λp. converse(fst(p)) ` snd(p))"
  using lam_replacement_cong[OF _ converse_apply_projs]
    lam_replacement_hcomp[OF lam_replacement_vimage_sing lam_replacement_Union]
  by simp

lemmas cardinal_lib_assms4 = lam_replacement_vimage_sing_fun[unfolded lam_replacement_def]

lemma lam_replacement_sing_const_id:
  "M(x) ⟹ lam_replacement(M, λy. {⟨x, y⟩})"
  using lam_replacement_hcomp[OF lam_replacement_const_id[of x]]
    lam_replacement_sing pair_in_M_iff
  by simp

lemma tag_singleton_closed: "M(x) ⟹ M(z) ⟹ M({{⟨z, y⟩} . y ∈ x})"
  using RepFun_closed[where A=x and f="λ u. {⟨z,u⟩}"]
    lam_replacement_imp_strong_replacement lam_replacement_sing_const_id
    transM[of _ x]
  by simp

lemma separation_eq:
  assumes "∀x[M]. M(f(x))" "lam_replacement(M,f)"
    "∀x[M]. M(g(x))" "lam_replacement(M,g)"
  shows "separation(M,λx . f(x) = g(x))"
proof -
  let ?Z="λA. {⟨x,⟨f(x),⟨g(x),x⟩⟩⟩. x∈A}"
  let ?Y="λA. {⟨⟨x,f(x)⟩,⟨g(x),x⟩⟩. x∈A}"
  note sndsnd = lam_replacement_hcomp[OF lam_replacement_snd lam_replacement_snd]
  note fstsnd = lam_replacement_hcomp[OF lam_replacement_snd lam_replacement_fst]
  note sndfst = lam_replacement_hcomp[OF lam_replacement_fst lam_replacement_snd]
  have "M(?Z(A))" if "M(A)" for A
    using assms lam_replacement_iff_lam_closed that
      lam_replacement_product[OF assms(2)
        lam_replacement_product[OF assms(4) lam_replacement_identity]]
    unfolding lam_def
    by auto
  moreover
  have "?Y(A) = {⟨⟨fst(x), fst(snd(x))⟩, fst(snd(snd(x))), snd(snd(snd(x)))⟩ . x ∈ ?Z(A)}" for A
    by auto
  moreover from calculation
  have "M(?Y(A))" if "M(A)" for A
    using
      lam_replacement_imp_strong_replacement[OF
        lam_replacement_product[OF
          lam_replacement_product[OF lam_replacement_fst fstsnd]
          lam_replacement_product[OF
            lam_replacement_hcomp[OF sndsnd lam_replacement_fst]
            lam_replacement_hcomp[OF lam_replacement_snd sndsnd]
            ]
          ], THEN RepFun_closed,simplified,of "?Z(A)"]
      fst_closed[OF transM] snd_closed[OF transM] that
    by auto
  then
  have "M({u∈?Y(A) . snd(fst(u)) = fst(snd(u))})" (is "M(?W(A))") if "M(A)" for A
    using that middle_separation assms
    by auto
  then
  have "M({fst(fst(u)) . u ∈ ?W(A)})" if "M(A)" for A
    using that lam_replacement_imp_strong_replacement[OF
        lam_replacement_hcomp[OF lam_replacement_fst lam_replacement_fst], THEN RepFun_closed]
      fst_closed[OF transM]
    by auto
  moreover
  have "{x∈A. f(x) = g(x)} = {fst(fst(u)) . u∈?W(A)}" for A
    by auto
  ultimately
  show ?thesis
    using separation_iff by auto
qed

lemma separation_subset:
  assumes "∀x[M]. M(f(x))" "lam_replacement(M,f)"
    "∀x[M]. M(g(x))" "lam_replacement(M,g)"
  shows "separation(M,λx . f(x) ⊆ g(x))"
proof -
  have "f(x) ⊆ g(x) ⟷ f(x)∪g(x) = g(x)" for x
    using subset_Un_iff by simp
  moreover from assms
  have "separation(M,λx . f(x)∪g(x) = g(x))"
    using separation_eq lam_replacement_Un lam_replacement_hcomp2
    by simp
  ultimately
  show ?thesis
    using separation_cong[THEN iffD1] by auto
qed

lemma separation_ball:
  assumes "separation(M, λy. f(fst(y),snd(y)))" "M(X)"
  shows "separation(M, λy. ∀u∈X. f(y,u))"
  unfolding separation_def
proof(clarify)
  fix A
  assume "M(A)"
  moreover
  note ‹M(X)›
  moreover from calculation
  have "M(A×X)"
    by simp
  then
  have "M({p ∈ A×X . f(fst(p),snd(p))})" (is "M(?P)")
    using assms(1)
    by auto
  moreover from calculation
  have "M({a∈A . ?P``{a} = X})" (is "M(?A')")
    using separation_eq lam_replacement_image_sing_fun[of "?P"] lam_replacement_constant
    by simp
  moreover
  have "f(a,x)" if "a∈?A'" and "x∈X" for a x
  proof -
    from that
    have "a∈A" "?P``{a}=X"
      by auto
    then
    have "x∈?P``{a}"
      using that by simp
    then
    show ?thesis using image_singleton_iff by simp
  qed
  moreover from this
  have "∀a[M]. a ∈ ?A' ⟷ a ∈ A ∧ (∀x∈X. f(a, x))"
    using image_singleton_iff
    by auto
  with ‹M(?A')›
  show "∃y[M]. ∀a[M]. a ∈ y ⟷ a ∈ A ∧ (∀x∈X. f(a, x))"
    by (rule_tac x="?A'" in rexI,simp_all)
qed

lemma lam_replacement_twist: "lam_replacement(M,λ⟨⟨x,y⟩,z⟩. ⟨x,y,z⟩)"
  using lam_replacement_fst lam_replacement_snd
    lam_replacement_Pair[THEN [5] lam_replacement_hcomp2,
      of "λx. snd(fst(x))" "λx. snd(x)", THEN [2] lam_replacement_Pair[
        THEN [5] lam_replacement_hcomp2, of "λx. fst(fst(x))"]]
    lam_replacement_hcomp unfolding split_def by simp

lemma twist_closed[intro,simp]: "M(x) ⟹ M((λ⟨⟨x,y⟩,z⟩. ⟨x,y,z⟩)(x))"
  unfolding split_def by simp

lemma lam_replacement_Lambda:
  assumes "lam_replacement(M, λy. b(fst(y), snd(y)))"
    "∀w[M]. ∀y[M]. M(b(w, y))" "M(W)"
  shows "lam_replacement(M, λx. λw∈W. b(x, w))"
proof (intro lam_replacement_iff_lam_closed[THEN iffD2]; clarify)
  have aux_sep: "∀x[M]. separation(M,λy. ⟨fst(x), y⟩ ∈ A)"
    if "M(X)" "M(A)" for X A
    using separation_in lam_replacement_hcomp2[OF lam_replacement_hcomp[OF  lam_replacement_constant lam_replacement_fst]
        lam_replacement_identity _ _ lam_replacement_Pair]
      lam_replacement_constant[of A]
      that
    by simp
  have aux_closed: "∀x[M]. M({y ∈ X . ⟨fst(x), y⟩ ∈ A})" if "M(X)" "M(A)" for X A
    using aux_sep that by simp
  have aux_lemma: "lam_replacement(M,λp . {y ∈ X . ⟨fst(p), y⟩ ∈ A})"
    if "M(X)" "M(A)" for X A
  proof -
    note lr = lam_replacement_Collect[OF ‹M(X)›]
    note fst3 = lam_replacement_hcomp[OF lam_replacement_fst
        lam_replacement_hcomp[OF lam_replacement_fst lam_replacement_fst]]
    then show ?thesis
      using lam_replacement_Collect[OF ‹M(X)› aux_sep separation_ball[OF separation_iff']]
        separation_in[OF _ lam_replacement_snd _ lam_replacement_hcomp[OF lam_replacement_fst lam_replacement_snd]]
        separation_in[OF _ lam_replacement_hcomp2[OF fst3 lam_replacement_snd _ _  lam_replacement_Pair] _
          lam_replacement_constant[of A]] that
      by auto
  qed
  from assms
  show lbc:"M(x) ⟹ M(λw∈W. b(x, w))" for x
    using lam_replacement_constant lam_replacement_identity
      lam_replacement_hcomp2[where h=b]
    by (intro lam_replacement_iff_lam_closed[THEN iffD1, rule_format])
      simp_all
  fix A
  assume "M(A)"
  moreover from this assms
  have "M({b(fst(x),snd(x)). x ∈ A×W})" (is "M(?RFb)")― ‹term‹RepFun› term‹b››
    using lam_replacement_imp_strong_replacement transM[of _ "A×W"]
    by (rule_tac RepFun_closed) auto
  moreover
  have "{⟨⟨x,y⟩,z⟩ ∈ (A×W)×?RFb. z = b(x,y)} = (λ⟨x,y⟩∈A×W. b(x,y)) ∩ (A×W)×?RFb"
    (is "{⟨⟨x,y⟩,z⟩ ∈ (A×W)×?B. _ } = ?lam")
    unfolding lam_def by auto
  moreover from calculation and assms
  have "M(?lam)"
    using lam_replacement_iff_lam_closed unfolding split_def by simp
  moreover
  have "{⟨⟨x,y⟩,z⟩ ∈ (X × Y) × Z . P(x, y, z)} ⊆ (X × Y) × Z" for X Y Z P
    by auto
  then
  have "{⟨x,y,z⟩ ∈ X×Y×Z. P(x,y,z) }= (λ⟨⟨x,y⟩,z⟩∈(X×Y)×Z. ⟨x,y,z⟩) ``
        {⟨⟨x,y⟩,z⟩ ∈ (X×Y)×Z. P(x,y,z) }" (is "?C' = Lambda(?A,?f) `` ?C")
    for X Y Z P
    using image_lam[of ?C ?A ?f]
    by (intro equalityI) (auto)
  with calculation
  have "{⟨x,y,z⟩ ∈ A×W×?RFb. z = b(x,y) } =
        (λ⟨⟨x,y⟩,z⟩∈(A×W)×?RFb. ⟨x,y,z⟩) `` ?lam" (is "?H = ?G ")
    by simp
  with ‹M(A)› ‹M(W)› ‹M(?lam)› ‹M(?RFb)›
  have "M(?H)"
    using lam_replacement_iff_lam_closed[THEN iffD1, rule_format, OF _ lam_replacement_twist]
    by simp
  moreover from this and ‹M(A)›
  have "(λx∈A. λw∈W. b(x, w)) =
    {⟨x,Z⟩ ∈ A × Pow⇗M⇖(range(?H)). Z = {y ∈ W×?RFb . ⟨x, y⟩ ∈ ?H}}"
    unfolding lam_def
    by (intro equalityI; subst Pow_rel_char[of "range(?H)"])
      (auto dest:transM simp: lbc[unfolded lam_def], force+)
  moreover from calculation and ‹M(A)› and ‹M(W)›
  have "M(A×Pow⇗M⇖(range(?H)))" "M(W×?RFb)"
    by auto
  moreover
  note ‹M(W)›
  moreover from calculation
  have "M({⟨x,Z⟩ ∈ A × Pow⇗M⇖(range(?H)). Z = {y ∈ W×?RFb . ⟨x, y⟩ ∈ ?H}})"
    using separation_eq[OF _ lam_replacement_snd
        aux_closed[OF ‹M(W×?RFb)› ‹M(?H)›]
        aux_lemma[OF ‹M(W×?RFb)› ‹M(?H)›]]
      ‹M(A×Pow⇗M⇖(_))› assms
    unfolding split_def
    by auto
  ultimately
  show "M(λx∈A. λw∈W. b(x, w))" by simp
qed

lemma lam_replacement_apply_Pair:
  assumes "M(y)"
  shows "lam_replacement(M, λx. y ` ⟨fst(x), snd(x)⟩)"
  using assms lam_replacement_constant lam_replacement_Pair
    lam_replacement_apply2[THEN [5] lam_replacement_hcomp2]
  by auto

lemma lam_replacement_apply_fst_snd:
  shows "lam_replacement(M, λw. fst(w) ` fst(snd(w)) ` snd(snd(w)))"
  using lam_replacement_fst lam_replacement_snd lam_replacement_hcomp
    lam_replacement_apply2[THEN [5] lam_replacement_hcomp2]
  by auto

lemma separation_snd_in_fst: "separation(M, λx. snd(x) ∈ fst(x))"
  using separation_in lam_replacement_fst lam_replacement_snd
  by auto

lemma lam_replacement_if_mem:
  "lam_replacement(M, λx. if snd(x) ∈ fst(x) then 1 else 0)"
  using separation_snd_in_fst
    lam_replacement_constant lam_replacement_if
  by auto

lemma lam_replacement_Lambda_apply_fst_snd:
  assumes "M(X)"
  shows "lam_replacement(M, λx. λw∈X. x ` fst(w) ` snd(w))"
  using assms lam_replacement_apply_fst_snd lam_replacement_Lambda
  by simp

lemma lam_replacement_Lambda_apply_Pair:
  assumes "M(X)" "M(y)"
  shows "lam_replacement(M, λx. λw∈X. y ` ⟨x, w⟩)"
  using assms lam_replacement_apply_Pair lam_replacement_Lambda
  by simp

lemma lam_replacement_Lambda_if_mem:
  assumes "M(X)"
  shows "lam_replacement(M, λx. λxa∈X. if xa ∈ x then 1 else 0)"
  using assms lam_replacement_if_mem lam_replacement_Lambda
  by simp

lemma lam_replacement_comp':
  "M(f) ⟹ M(g) ⟹ lam_replacement(M, λx . f O x O g)"
  using lam_replacement_comp[THEN [5] lam_replacement_hcomp2,
      OF lam_replacement_constant lam_replacement_comp,
      THEN [5] lam_replacement_hcomp2] lam_replacement_constant
    lam_replacement_identity by simp

lemma separation_bex:
  assumes "separation(M, λy. f(fst(y),snd(y)))" "M(X)"
  shows "separation(M, λy. ∃u∈X. f(y,u))"
  unfolding separation_def
proof(clarify)
  fix A
  assume "M(A)"
  moreover
  note ‹M(X)›
  moreover from calculation
  have "M(A×X)"
    by simp
  then
  have "M({p ∈ A×X . f(fst(p),snd(p))})" (is "M(?P)")
    using assms(1)
    by auto
  moreover from calculation
  have "M({a∈A . ?P``{a} ≠ 0})" (is "M(?A')")
    using separation_eq lam_replacement_image_sing_fun[of "?P"] lam_replacement_constant
      separation_neg
    by simp
  moreover from this
  have "∀a[M]. a ∈ ?A' ⟷ a ∈ A ∧ (∃x∈X. f(a, x))"
    using image_singleton_iff
    by auto
  with ‹M(?A')›
  show "∃y[M]. ∀a[M]. a ∈ y ⟷ a ∈ A ∧ (∃x∈X. f(a, x))"
    by (rule_tac x="?A'" in rexI,simp_all)
qed

lemma case_closed :
  assumes "∀x[M]. M(f(x))" "∀x[M]. M(g(x))"
  shows "∀x[M]. M(case(f,g,x))"
  unfolding case_def split_def cond_def
  using assms by simp

lemma separation_fst_equal : "M(a) ⟹ separation(M,λx . fst(x)=a)"
  using separation_eq lam_replacement_fst lam_replacement_constant
  by auto

lemma lam_replacement_case :
  assumes "lam_replacement(M,f)" "lam_replacement(M,g)"
    "∀x[M]. M(f(x))" "∀x[M]. M(g(x))"
  shows "lam_replacement(M, λx . case(f,g,x))"
  unfolding case_def split_def cond_def
  using lam_replacement_if separation_fst_equal
    lam_replacement_hcomp[of "snd" g]
    lam_replacement_hcomp[of "snd" f]
    lam_replacement_snd assms
  by simp

lemma Pi_replacement1: "M(x) ⟹ M(y) ⟹  strong_replacement(M, λya z. ya ∈ y ∧ z = {⟨x, ya⟩})"
  using lam_replacement_imp_strong_replacement
    strong_replacement_separation[OF lam_replacement_sing_const_id[of x],where P="λx . x ∈y"]
    separation_in_constant
  by simp

lemma surj_imp_inj_replacement1:
  "M(f) ⟹ M(x) ⟹ strong_replacement(M, λy z. y ∈ f -`` {x} ∧ z = {⟨x, y⟩})"
  using Pi_replacement1 vimage_closed singleton_closed
  by simp

lemmas domain_replacement = lam_replacement_domain[unfolded lam_replacement_def]

lemma domain_replacement_simp: "strong_replacement(M, λx y. y=domain(x))"
  using lam_replacement_domain lam_replacement_imp_strong_replacement by simp

lemma un_Pair_replacement: "M(p) ⟹ strong_replacement(M, λx y . y = x∪{p})"
  using lam_replacement_Un_const[THEN lam_replacement_imp_strong_replacement] by simp

lemma diff_replacement: "M(X) ⟹ strong_replacement(M, λx y. y = x - X)"
  using lam_replacement_Diff'[THEN lam_replacement_imp_strong_replacement] by simp

lemma lam_replacement_succ:
  "lam_replacement(M,λz . succ(z))"
  unfolding succ_def
  using lam_replacement_hcomp2[of "λx. x" "λx. x" cons]
    lam_replacement_cons lam_replacement_identity
  by simp

lemma lam_replacement_hcomp_Least:
  assumes "lam_replacement(M, g)" "lam_replacement(M,λx. μ i. x∈F(i,x))"
    "∀x[M]. M(g(x))" "⋀x i. M(x) ⟹ i ∈ F(i, x) ⟹ M(i)"
  shows "lam_replacement(M,λx. μ i. g(x)∈F(i,g(x)))"
  using assms
  by (rule_tac lam_replacement_hcomp[of _ "λx. μ i. x∈F(i,x)"])
    (auto intro:Least_closed')

lemma domain_mem_separation: "M(A) ⟹ separation(M, λx . domain(x)∈A)"
  using separation_in lam_replacement_constant lam_replacement_domain
  by auto

lemma domain_eq_separation: "M(p) ⟹ separation(M, λx . domain(x) = p)"
  using separation_eq lam_replacement_domain lam_replacement_constant
  by auto

lemma lam_replacement_Int:
  shows "lam_replacement(M, λx. fst(x) ∩ snd(x))"
proof -
  have "A∩B = (A∪B) - ((A- B) ∪ (B-A))" (is "_=?f(A,B)")for A B
    by auto
  then
  show ?thesis
    using lam_replacement_cong
      lam_replacement_Diff[THEN[5] lam_replacement_hcomp2]
      lam_replacement_Un[THEN[5] lam_replacement_hcomp2]
      lam_replacement_fst lam_replacement_snd
    by simp
qed

lemma lam_replacement_CartProd:
  assumes "lam_replacement(M,f)" "lam_replacement(M,g)"
    "∀x[M]. M(f(x))" "∀x[M]. M(g(x))"
  shows "lam_replacement(M, λx. f(x) × g(x))"
proof -
  note rep_closed = lam_replacement_imp_strong_replacement[THEN RepFun_closed]
  {
    fix A
    assume "M(A)"
    moreover
    note transM[OF _ ‹M(A)›]
    moreover from calculation assms
    have "M({⟨x,⟨f(x),g(x)⟩⟩ . x∈A})" (is "M(?A')")
      using lam_replacement_product[THEN lam_replacement_imp_lam_closed[unfolded lam_def]]
      by simp
    moreover from calculation
    have "M(⋃{f(x) . x∈A})" (is "M(?F)")
      using rep_closed[OF assms(1)] assms(3)
      by simp
    moreover from calculation
    have "M(⋃{g(x) . x∈A})" (is "M(?G)")
      using rep_closed[OF assms(2)] assms(4)
      by simp
    moreover from calculation
    have "M(?A' × (?F × ?G))" (is "M(?T)")
      by simp
    moreover from this
    have "M({t ∈ ?T . fst(snd(t)) ∈ fst(snd(fst(t))) ∧ snd(snd(t)) ∈ snd(snd(fst(t)))})" (is "M(?Q)")
      using
        lam_replacement_hcomp[OF lam_replacement_hcomp[OF lam_replacement_fst lam_replacement_snd] _ ]
        lam_replacement_hcomp lam_replacement_identity  lam_replacement_fst lam_replacement_snd
        separation_in separation_conj
      by simp
    moreover from this
    have "M({⟨fst(fst(t)),snd(t)⟩ . t∈?Q})" (is "M(?R)")
      using rep_closed lam_replacement_Pair[THEN [5] lam_replacement_hcomp2]
        lam_replacement_hcomp[OF lam_replacement_fst lam_replacement_fst] lam_replacement_snd
        transM[of _ ?Q]
      by simp
    moreover from calculation
    have "M({⟨x,?R``{x}⟩ . x∈A})"
      using lam_replacement_imp_lam_closed[unfolded lam_def] lam_replacement_sing
        lam_replacement_Image[THEN [5] lam_replacement_hcomp2] lam_replacement_constant[of ?R]
      by simp
    moreover
    have "?R``{x} = f(x)×g(x)" if "x∈A" for x
      by(rule equalityI subsetI,force,rule subsetI,rule_tac a="x" in imageI)
        (auto simp:that,(rule_tac rev_bexI[of x],simp_all add:that)+)
    ultimately
    have "M({⟨x,f(x) × g(x)⟩ . x∈A})" by auto
  }
  with assms
  show ?thesis using lam_replacement_iff_lam_closed[THEN iffD2,unfolded lam_def]
    by simp
qed

lemma restrict_eq_separation': "M(B) ⟹ ∀A[M]. separation(M, λy. ∃x∈A. y = ⟨x, restrict(x, B)⟩)"
proof(clarify)
  fix A
  have "restrict(r,B) = r ∩ (B × range(r))" for r
    unfolding restrict_def by(rule equalityI subsetI,auto)
  moreover
  assume "M(A)" "M(B)"
  moreover from this
  have "separation(M, λy. ∃x∈A. y = ⟨x, x ∩ (B × range(x))⟩)"
    using lam_replacement_Int[THEN[5] lam_replacement_hcomp2]
      lam_replacement_Pair[THEN[5] lam_replacement_hcomp2]
    using lam_replacement_fst lam_replacement_snd lam_replacement_constant
      lam_replacement_hcomp lam_replacement_range lam_replacement_identity
      lam_replacement_CartProd separation_bex separation_eq
    by simp_all
  ultimately
  show "separation(M, λy. ∃x∈A. y = ⟨x, restrict(x, B)⟩)"
    by simp
qed

lemmas lam_replacement_restrict' = lam_replacement_restrict[OF restrict_eq_separation']

lemma restrict_strong_replacement: "M(A) ⟹ strong_replacement(M, λx y. y=restrict(x,A))"
  using lam_replacement_restrict restrict_eq_separation'
    lam_replacement_imp_strong_replacement
  by simp

lemma restrict_eq_separation: "M(r) ⟹ M(p) ⟹ separation(M, λx . restrict(x,r) = p)"
  using separation_eq lam_replacement_restrict' lam_replacement_constant
  by auto

lemma separation_equal_fst2 : "M(a) ⟹ separation(M,λx . fst(fst(x))=a)"
  using separation_eq lam_replacement_hcomp lam_replacement_fst lam_replacement_constant
  by auto

lemma separation_equal_apply: "M(f) ⟹ M(a) ⟹ separation(M,λx. f`x=a)"
  using separation_eq lam_replacement_apply[of f] lam_replacement_constant
  by auto

lemma lam_apply_replacement: "M(A) ⟹ M(f) ⟹ lam_replacement(M, λx . λn∈A. f ` ⟨x, n⟩)"
  using lam_replacement_Lambda lam_replacement_hcomp[OF _ lam_replacement_apply[of f]] lam_replacement_Pair
  by simp

lemma separation_all:
  assumes "separation(M, λx  .P(fst(x),snd(x)))"
  shows "separation(M, λz. ∀x∈z. P(z,x))"
  unfolding separation_def
proof(clarify)
  fix A
  assume "M(A)"
  let ?B="⋃A"
  let ?C="A×?B"
  note ‹M(A)›
  moreover from calculation
  have "M(?C)"
    by simp
  moreover from calculation
  have "M({p∈?C . P(fst(p),snd(p)) ∧ snd(p)∈fst(p)})" (is "M(?Prod)")
    using assms separation_conj separation_in lam_replacement_fst lam_replacement_snd
    by simp
  moreover from calculation
  have "M({z∈A . z=?Prod``{z}})" (is "M(?L)")
    using separation_eq lam_replacement_identity
      lam_replacement_constant[of ?Prod] lam_replacement_image_sing_fun
    by simp
  moreover
  have "?L = {z∈A . ∀x∈z. P(z,x)}"
  proof -
    have "P(z,x)" if "z∈A" "x∈z" "x∈?Prod``{z}" for z x
      using that
      by auto
    moreover
    have "z = ?Prod `` {z}" if "z∈A" "∀x∈z. P(z, x)" for z
      using that
      by(intro equalityI subsetI,auto)
    ultimately
    show ?thesis
      by(intro equalityI subsetI,auto)
  qed
  ultimately
  show " ∃y[M]. ∀z[M]. z ∈ y ⟷ z ∈ A ∧ (∀x∈z . P(z,x))"
    by (rule_tac x="?L" in rexI,simp_all)
qed

lemma separation_Transset: "separation(M,Transset)"
  unfolding Transset_def
  using separation_all separation_subset lam_replacement_fst lam_replacement_snd
  by auto

lemma separation_comp :
  assumes "separation(M,P)" "lam_replacement(M,f)" "∀x[M]. M(f(x))"
  shows "separation(M,λx. P(f(x)))"
  unfolding separation_def
proof(clarify)
  fix A
  assume "M(A)"
  let ?B="{f(a) . a ∈ A}"
  let ?C="A×{b∈?B . P(b)}"
  note ‹M(A)›
  moreover from calculation
  have "M(?C)"
    using lam_replacement_imp_strong_replacement assms RepFun_closed transM[of _ A]
    by simp
  moreover from calculation
  have "M({p∈?C . f(fst(p)) = snd(p)})" (is "M(?Prod)")
    using assms separation_eq lam_replacement_fst lam_replacement_snd
      lam_replacement_hcomp
    by simp
  moreover from calculation
  have "M({fst(p) . p∈?Prod})" (is "M(?L)")
    using lam_replacement_imp_strong_replacement lam_replacement_fst RepFun_closed
      transM[of _ ?Prod]
    by simp
  moreover
  have "?L = {z∈A . P(f(z))}"
    by(intro equalityI subsetI,auto)
  ultimately
  show " ∃y[M]. ∀z[M]. z ∈ y ⟷ z ∈ A ∧ P(f(z))"
    by (rule_tac x="?L" in rexI,simp_all)
qed

lemma separation_Ord: "separation(M,Ord)"
  unfolding Ord_def
  using separation_conj separation_Transset separation_all
    separation_comp separation_Transset lam_replacement_snd
  by auto

end ― ‹locale‹M_replacement››

locale M_replacement_extra = M_replacement +
  assumes
    lam_replacement_minimum:"lam_replacement(M, λp. minimum(fst(p),snd(p)))"
    and
    lam_replacement_RepFun_cons:"lam_replacement(M, λp. RepFun(fst(p), λx. {⟨snd(p),x⟩}))"
    ― ‹This one is too particular: It is for term‹Sigfun›.
        I would like greater modularity here.›

begin
lemma lam_replacement_Sigfun:
  assumes "lam_replacement(M,f)" "∀y[M]. M(f(y))"
  shows "lam_replacement(M, λx. Sigfun(x,f))"
  using lam_replacement_Union lam_replacement_identity
    lam_replacement_sing[THEN lam_replacement_imp_strong_replacement]
    lam_replacement_hcomp[of _ Union] assms tag_singleton_closed
    lam_replacement_RepFun_cons[THEN [5] lam_replacement_hcomp2]
  unfolding Sigfun_def
  by (rule_tac lam_replacement_hcomp[of _ Union],simp_all)

subsection‹Particular instances›

lemma surj_imp_inj_replacement2:
  "M(f) ⟹ strong_replacement(M, λx z. z = Sigfun(x, λy. f -`` {y}))"
  using lam_replacement_imp_strong_replacement lam_replacement_Sigfun
    lam_replacement_vimage_sing_fun
  by simp

lemma lam_replacement_minimum_vimage:
  "M(f) ⟹ M(r) ⟹ lam_replacement(M, λx. minimum(r, f -`` {x}))"
  using lam_replacement_minimum lam_replacement_vimage_sing_fun lam_replacement_constant
  by (rule_tac lam_replacement_hcomp2[of _ _ minimum])
    (force intro: lam_replacement_identity)+

lemmas surj_imp_inj_replacement4 = lam_replacement_minimum_vimage[unfolded lam_replacement_def]

lemma lam_replacement_Pi: "M(y) ⟹ lam_replacement(M, λx. ⋃xa∈y. {⟨x, xa⟩})"
  using lam_replacement_Union lam_replacement_identity lam_replacement_constant
    lam_replacement_RepFun_cons[THEN [5] lam_replacement_hcomp2] tag_singleton_closed
  by (rule_tac lam_replacement_hcomp[of _ Union],simp_all)

lemma Pi_replacement2: "M(y) ⟹ strong_replacement(M, λx z. z = (⋃xa∈y. {⟨x, xa⟩}))"
  using lam_replacement_Pi[THEN lam_replacement_imp_strong_replacement, of y]
proof -
  assume "M(y)"
  then
  have "M(x) ⟹ M(⋃xa∈y. {⟨x, xa⟩})" for x
    using tag_singleton_closed
    by (rule_tac Union_closed RepFun_closed)
  with ‹M(y)›
  show ?thesis
    using lam_replacement_Pi[THEN lam_replacement_imp_strong_replacement, of y]
    by blast
qed

lemma if_then_Inj_replacement:
  shows "M(A) ⟹ strong_replacement(M, λx y. y = ⟨x, if x ∈ A then Inl(x) else Inr(x)⟩)"
  using lam_replacement_if lam_replacement_Inl lam_replacement_Inr separation_in_constant
  unfolding lam_replacement_def
  by simp

lemma lam_if_then_replacement:
  "M(b) ⟹
    M(a) ⟹ M(f) ⟹ strong_replacement(M, λy ya. ya = ⟨y, if y = a then b else f ` y⟩)"
  using lam_replacement_if lam_replacement_apply lam_replacement_constant
    separation_equal
  unfolding lam_replacement_def
  by simp

lemma if_then_replacement:
  "M(A) ⟹ M(f) ⟹ M(g) ⟹ strong_replacement(M, λx y. y = ⟨x, if x ∈ A then f ` x else g ` x⟩)"
  using lam_replacement_if lam_replacement_apply[of f] lam_replacement_apply[of g]
    separation_in_constant
  unfolding lam_replacement_def
  by simp

lemma ifx_replacement:
  "M(f) ⟹
    M(b) ⟹ strong_replacement(M, λx y. y = ⟨x, if x ∈ range(f) then converse(f) ` x else b⟩)"
  using lam_replacement_if lam_replacement_apply lam_replacement_constant
    separation_in_constant
  unfolding lam_replacement_def
  by simp

lemma if_then_range_replacement2:
  "M(A) ⟹ M(C) ⟹ strong_replacement(M, λx y. y = ⟨x, if x = Inl(A) then C else x⟩)"
  using lam_replacement_if lam_replacement_constant lam_replacement_identity
    separation_equal
  unfolding lam_replacement_def
  by simp

lemma if_then_range_replacement:
  "M(u) ⟹
    M(f) ⟹
    strong_replacement
     (M,
      λz y. y = ⟨z, if z = u then f ` 0 else if z ∈ range(f) then f ` succ(converse(f) ` z) else z⟩)"
  using lam_replacement_if separation_equal separation_in_constant
    lam_replacement_constant lam_replacement_identity
    lam_replacement_succ lam_replacement_apply
    lam_replacement_hcomp[of "λx. converse(f)`x" "succ"]
    lam_replacement_hcomp[of "λx. succ(converse(f)`x)" "λx . f`x"]
  unfolding lam_replacement_def
  by simp

lemma Inl_replacement2:
  "M(A) ⟹
    strong_replacement(M, λx y. y = ⟨x, if fst(x) = A then Inl(snd(x)) else Inr(x)⟩)"
  using lam_replacement_if separation_fst_equal
    lam_replacement_hcomp[of "snd" "Inl"]
    lam_replacement_Inl lam_replacement_Inr lam_replacement_snd
  unfolding lam_replacement_def
  by simp

lemma case_replacement1:
  "strong_replacement(M, λz y. y = ⟨z, case(Inr, Inl, z)⟩)"
  using lam_replacement_case lam_replacement_Inl lam_replacement_Inr
  unfolding lam_replacement_def
  by simp

lemma case_replacement2:
  "strong_replacement(M, λz y. y = ⟨z, case(case(Inl, λy. Inr(Inl(y))), λy. Inr(Inr(y)), z)⟩)"
  using lam_replacement_case lam_replacement_hcomp
    case_closed[of Inl "λx. Inr(Inl(x))"]
    lam_replacement_Inl lam_replacement_Inr
  unfolding lam_replacement_def
  by simp

lemma case_replacement4:
  "M(f) ⟹ M(g) ⟹ strong_replacement(M, λz y. y = ⟨z, case(λw. Inl(f ` w), λy. Inr(g ` y), z)⟩)"
  using lam_replacement_case lam_replacement_hcomp
    lam_replacement_Inl lam_replacement_Inr lam_replacement_apply
  unfolding lam_replacement_def
  by simp

lemma case_replacement5:
  "strong_replacement(M, λx y. y = ⟨x, (λ⟨x,z⟩. case(λy. Inl(⟨y, z⟩), λy. Inr(⟨y, z⟩), x))(x)⟩)"
  unfolding split_def case_def cond_def
  using lam_replacement_if separation_equal_fst2
    lam_replacement_snd lam_replacement_Inl lam_replacement_Inr
    lam_replacement_hcomp[OF
      lam_replacement_product[OF
        lam_replacement_hcomp[OF lam_replacement_fst lam_replacement_snd]]]
  unfolding lam_replacement_def
  by simp

end ― ‹locale‹M_replacement_extra››

― ‹To be used in the relativized treatment of Cohen posets›
definition
  ― ‹"domain collect F"›
  dC_F :: "i ⇒ i ⇒ i" where
  "dC_F(A,d) ≡ {p ∈ A. domain(p) = d }"

definition
  ― ‹"domain restrict SepReplace Y"›
  drSR_Y :: "i ⇒ i ⇒ i ⇒ i ⇒ i" where
  "drSR_Y(B,D,A,x) ≡ {y . r∈A , restrict(r,B) = x ∧ y = domain(r) ∧ domain(r) ∈ D}"

lemma drSR_Y_equality: "drSR_Y(B,D,A,x) = { dr∈D . (∃r∈A . restrict(r,B) = x ∧ dr=domain(r)) }"
  unfolding drSR_Y_def by auto

context M_replacement_extra
begin

lemma separation_restrict_eq_dom_eq:"∀x[M].separation(M, λdr. ∃r∈A . restrict(r,B) = x ∧ dr=domain(r))"
  if "M(A)" and "M(B)" for A B
  using that
    separation_eq[OF _
      lam_replacement_fst _
      lam_replacement_hcomp[OF lam_replacement_snd lam_replacement_domain ]]
    separation_eq[OF _
      lam_replacement_hcomp[OF lam_replacement_snd lam_replacement_restrict'] _
      lam_replacement_constant]
  by(clarify,rule_tac separation_bex[OF _ ‹M(A)›],rule_tac separation_conj,simp_all)


lemma separation_is_insnd_restrict_eq_dom : "separation(M, λp. ∀x∈D. x ∈ snd(p) ⟷ (∃r∈A. restrict(r, B) = fst(p) ∧ x = domain(r)))"
  if "M(B)" "M(D)" "M(A)" for A B D
  using that lam_replacement_fst lam_replacement_hcomp lam_replacement_snd separation_in
    separation_eq[OF _
      lam_replacement_hcomp[OF lam_replacement_fst lam_replacement_snd] _
      lam_replacement_hcomp[OF lam_replacement_snd lam_replacement_domain]]
    separation_eq separation_restrict_eq_dom_eq
    lam_replacement_hcomp[OF lam_replacement_snd lam_replacement_restrict']
    lam_replacement_hcomp[OF lam_replacement_fst
      lam_replacement_hcomp[OF lam_replacement_fst lam_replacement_fst]]
  by(rule_tac separation_ball,rule_tac separation_iff',simp_all,
      rule_tac separation_bex[OF _ ‹M(A)›],rule_tac separation_conj,simp_all)

lemma lam_replacement_drSR_Y:
  assumes
    "M(B)" "M(D)" "M(A)"
  shows "lam_replacement(M, drSR_Y(B,D,A))"
  using lam_replacement_cong lam_replacement_Collect[OF ‹M(D)› separation_restrict_eq_dom_eq[of A B]]
    assms drSR_Y_equality separation_is_insnd_restrict_eq_dom separation_restrict_eq_dom_eq
  by simp

lemma drSR_Y_closed:
  assumes
    "M(B)" "M(D)" "M(A)" "M(f)"
  shows "M(drSR_Y(B,D,A,f))"
  using assms drSR_Y_equality lam_replacement_Collect[OF ‹M(D)› separation_restrict_eq_dom_eq[of A B]]
    assms drSR_Y_equality separation_is_insnd_restrict_eq_dom separation_restrict_eq_dom_eq
  by simp

lemma lam_if_then_apply_replacement: "M(f) ⟹ M(v) ⟹ M(u) ⟹
     lam_replacement(M, λx. if f ` x = v then f ` u else f ` x)"
  using lam_replacement_if separation_equal_apply lam_replacement_constant lam_replacement_apply
  by simp

lemma  lam_if_then_apply_replacement2: "M(f) ⟹ M(m) ⟹ M(y) ⟹
     lam_replacement(M, λz . if f ` z = m then y else f ` z)"
  using lam_replacement_if separation_equal_apply lam_replacement_constant lam_replacement_apply
  by simp

lemma lam_if_then_replacement2: "M(A) ⟹ M(f) ⟹
     lam_replacement(M, λx . if x ∈ A then f ` x else x)"
  using lam_replacement_if separation_in_constant lam_replacement_identity lam_replacement_apply
  by simp

lemma lam_if_then_replacement_apply: "M(G) ⟹ lam_replacement(M, λx. if M(x) then G ` x else 0)"
  using lam_replacement_if separation_in_constant lam_replacement_identity lam_replacement_apply
    lam_replacement_constant[of 0] separation_univ
  by simp

lemma lam_replacement_dC_F:
  assumes "M(A)"
  shows "lam_replacement(M, dC_F(A))"
proof -
  have "separation(M, λp. ∀x∈A. x ∈ snd(p) ⟷ domain(x) = fst(p))" if "M(A)" for A
    using separation_ball separation_iff'
      lam_replacement_hcomp lam_replacement_fst lam_replacement_snd lam_replacement_domain
      separation_in separation_eq that
    by simp_all
  then
  show ?thesis
    unfolding dC_F_def
    using assms lam_replacement_Collect[of A "λ d x . domain(x) = d"]
      separation_eq[OF _ lam_replacement_domain _ lam_replacement_constant]
    by simp
qed

lemma dCF_closed:
  assumes "M(A)" "M(f)"
  shows "M(dC_F(A,f))"
  unfolding dC_F_def
  using assms lam_replacement_Collect[of A "λ d x . domain(x) = d"]
    separation_eq[OF _ lam_replacement_domain _ lam_replacement_constant]
  by simp

lemma lam_replacement_min: "M(f) ⟹ M(r) ⟹ lam_replacement(M, λx . minimum(r, f -`` {x}))"
  using lam_replacement_hcomp2[OF lam_replacement_constant[of r] lam_replacement_vimage_sing_fun]
    lam_replacement_minimum
  by simp

lemma lam_replacement_Collect_ball_Pair:
  assumes "separation(M, λp. ∀x∈G. x ∈ snd(p) ⟷ (∀s∈fst(p). ⟨s, x⟩ ∈ Q))" "M(G)" "M(Q)"
  shows "lam_replacement(M, λx . {a ∈ G . ∀s∈x. ⟨s, a⟩ ∈ Q})"
proof -
  have 1:"∀x[M]. separation(M, λa .  ∀s∈x. ⟨s, a⟩ ∈ Q)" if "M(Q)" for Q
    using separation_in lam_replacement_hcomp2[OF _ _ _ _ lam_replacement_Pair]
      lam_replacement_constant separation_ball
      lam_replacement_hcomp lam_replacement_fst lam_replacement_snd that
    by simp
  then
  show ?thesis
    using assms lam_replacement_Collect
    by simp_all
qed

lemma surj_imp_inj_replacement3:
  "(⋀x. M(x) ⟹ separation(M, λy. ∀s∈x. ⟨s, y⟩ ∈ Q)) ⟹ M(G) ⟹ M(Q) ⟹ M(x) ⟹
  strong_replacement(M, λy z. y ∈ {a ∈ G . ∀s∈x. ⟨s, a⟩ ∈ Q} ∧ z = {⟨x, y⟩})"
  using lam_replacement_imp_strong_replacement
  using lam_replacement_sing_const_id[THEN lam_replacement_imp_strong_replacement, of x]
  unfolding strong_replacement_def
  by (simp, safe, drule_tac x="A ∩ {a ∈ G . ∀s∈x. ⟨s, a⟩ ∈ Q}" in rspec,
      simp, erule_tac rexE, rule_tac x=Y in rexI) auto

lemmas replacements = Pair_diff_replacement id_replacement tag_replacement
  pospend_replacement prepend_replacement
  Inl_replacement1  diff_Pair_replacement
  swap_replacement tag_union_replacement csquare_lam_replacement
  assoc_replacement prod_fun_replacement
  cardinal_lib_assms4  domain_replacement
  apply_replacement
  un_Pair_replacement restrict_strong_replacement diff_replacement
  if_then_Inj_replacement lam_if_then_replacement if_then_replacement
  ifx_replacement if_then_range_replacement2 if_then_range_replacement
  Inl_replacement2
  case_replacement1 case_replacement2 case_replacement4 case_replacement5

end ― ‹locale‹M_replacement_extra››

end
>

Theory Discipline_Cardinal

theory Discipline_Cardinal
  imports
    Discipline_Function
begin

declare [[syntax_ambiguity_warning = false]]

relativize functional "cardinal" "cardinal_rel" external
relationalize "cardinal_rel" "is_cardinal"
synthesize "is_cardinal" from_definition assuming "nonempty"

notation is_cardinal_fm (‹cardinal'(_') is _›)

abbreviation
  cardinal_r :: "[i,i⇒o] ⇒ i" (‹|_|⇗_⇖›) where
  "|x|⇗M⇖ ≡ cardinal_rel(M,x)"

abbreviation
  cardinal_r_set :: "[i,i]⇒i"  (‹|_|⇗_⇖›) where
  "|x|⇗M⇖ ≡ cardinal_rel(##M,x)"

context M_trivial begin
rel_closed for "cardinal"
  using Least_closed'[of "λi. M(i) ∧ i ≈⇗M⇖ A"]
  unfolding cardinal_rel_def
  by simp
end

manual_arity intermediate for "is_Int_fm"
  unfolding is_Int_fm_def
  using arity pred_Un_distrib
  by (simp)

arity_theorem for "is_Int_fm"

arity_theorem for "is_funspace_fm"

arity_theorem for "is_function_space_fm"

arity_theorem for "surjP_rel_fm"

arity_theorem intermediate for "is_surj_fm"

lemma arity_is_surj_fm [arity] :
  "A ∈ nat ⟹ B ∈ nat ⟹ I ∈ nat ⟹ arity(is_surj_fm(A, B, I)) = succ(A) ∪ succ(B) ∪ succ(I)"
  using arity_is_surj_fm' pred_Un_distrib
  by auto

arity_theorem for "injP_rel_fm"

arity_theorem intermediate for "is_inj_fm"

lemma arity_is_inj_fm [arity]:
  "A ∈ nat ⟹ B ∈ nat ⟹ I ∈ nat ⟹ arity(is_inj_fm(A, B, I)) = succ(A) ∪ succ(B) ∪ succ(I)"
  using arity_is_inj_fm' pred_Un_distrib
  by auto

arity_theorem for "is_bij_fm"

arity_theorem for "is_eqpoll_fm"

arity_theorem for "is_cardinal_fm"

context M_Perm begin

is_iff_rel for "cardinal"
  using least_abs'[of "λi. M(i) ∧ i ≈⇗M⇖ A"]
    is_eqpoll_iff
  unfolding is_cardinal_def cardinal_rel_def
  by simp
end

reldb_add functional "Ord" "Ord"
reldb_add relational "Ord" "ordinal"
reldb_add functional "lt" "lt"
reldb_add relational "lt" "lt_rel"
synthesize "lt_rel" from_definition
notation lt_rel_fm (‹⋅_ < _⋅›)
arity_theorem intermediate for "lt_rel_fm"

lemma arity_lt_rel_fm[arity]: "a ∈ nat ⟹ b ∈ nat ⟹ arity(lt_rel_fm(a, b)) = succ(a) ∪ succ(b)"
  using arity_lt_rel_fm'
  by auto

relativize functional "Card" "Card_rel" external
relationalize "Card_rel" "is_Card"
synthesize "is_Card" from_definition assuming "nonempty"
notation is_Card_fm (‹⋅Card'(_')⋅›)
arity_theorem for "is_Card_fm"

notation Card_rel (‹Card⇗_⇖'(_')›)

lemma (in M_Perm) is_Card_iff: "M(A) ⟹ is_Card(M, A) ⟷ Card⇗M⇖(A)"
  using is_cardinal_iff
  unfolding is_Card_def Card_rel_def by simp

abbreviation
  Card_r_set  :: "[i,i]⇒o"  (‹Card⇗_⇖'(_')›) where
  "Card⇗M⇖(i) ≡ Card_rel(##M,i)"

relativize functional "InfCard" "InfCard_rel" external
relationalize "InfCard_rel" "is_InfCard"
synthesize "is_InfCard" from_definition assuming "nonempty"
notation is_InfCard_fm (‹⋅InfCard'(_')⋅›)
arity_theorem for "is_InfCard_fm"

notation InfCard_rel (‹InfCard⇗_⇖'(_')›)

abbreviation
  InfCard_r_set  :: "[i,i]⇒o"  (‹InfCard⇗_⇖'(_')›) where
  "InfCard⇗M⇖(i) ≡ InfCard_rel(##M,i)"

relativize functional "cadd" "cadd_rel" external

abbreviation
  cadd_r :: "[i,i⇒o,i] ⇒ i" (‹_ ⊕⇗_⇖ _› [66,1,66] 65) where
  "A ⊕⇗M⇖ B ≡ cadd_rel(M,A,B)"

context M_basic begin
rel_closed for "cadd"
  using cardinal_rel_closed
  unfolding cadd_rel_def
  by simp
end

(* relativization *)

relationalize "cadd_rel" "is_cadd"

manual_schematic for "is_cadd" assuming "nonempty"
  unfolding is_cadd_def
  by (rule iff_sats sum_iff_sats | simp)+
synthesize "is_cadd" from_schematic

arity_theorem for "sum_fm"

arity_theorem for "is_cadd_fm"

context M_Perm begin
is_iff_rel for "cadd"
  using is_cardinal_iff
  unfolding is_cadd_def cadd_rel_def
  by simp
end

relativize functional "cmult" "cmult_rel" external

abbreviation
  cmult_r :: "[i,i⇒o,i] ⇒ i" (‹_ ⊗⇗_⇖ _› [66,1,66] 65) where
  "A ⊗⇗M⇖ B ≡ cmult_rel(M,A,B)"

(* relativization *)
relationalize "cmult_rel" "is_cmult"

declare cartprod_iff_sats [iff_sats]

synthesize "is_cmult" from_definition assuming "nonempty"

arity_theorem for "is_cmult_fm"

context M_Perm begin

rel_closed for "cmult"
  using cardinal_rel_closed
  unfolding cmult_rel_def
  by simp

is_iff_rel for "cmult"
  using is_cardinal_iff
  unfolding is_cmult_def cmult_rel_def
  by simp

end

end
ody>

Theory Univ_Relative

section‹Relativization of the cumulative hierarchy›
theory Univ_Relative
  imports
    "ZF-Constructible.Rank"
    "ZF.Univ"
    Discipline_Cardinal

begin

declare arity_ordinal_fm[arity]

context M_trivial
begin
declare powerset_abs[simp]

lemma family_union_closed: "⟦strong_replacement(M, λx y. y = f(x)); M(A); ∀x∈A. M(f(x))⟧
      ⟹ M(⋃x∈A. f(x))"
  using RepFun_closed ..

lemma family_union_closed': "⟦strong_replacement(M, λx y. x∈A ∧ y = f(x)); M(A); ∀x∈A. M(f(x))⟧
      ⟹ M(⋃x∈A. f(x))"
  using RepFun_closed2
  by simp

end ― ‹locale‹M_trivial››

definition
  Powapply :: "[i,i] ⇒ i"  where
  "Powapply(f,y) ≡ Pow(f`y)"

reldb_add functional "Pow" "Pow_rel"
reldb_add relational "Pow" "is_Pow"

declare Replace_iff_sats[iff_sats]
synthesize "is_Pow" from_definition assuming "nonempty"
arity_theorem for "is_Pow_fm"

relativize functional "Powapply" "Powapply_rel"
relationalize "Powapply_rel" "is_Powapply"
synthesize "is_Powapply" from_definition assuming "nonempty"
arity_theorem for "is_Powapply_fm"

notation Powapply_rel (‹Powapply⇗_⇖'(_,_')›)

context M_basic
begin

rel_closed for "Powapply"
  unfolding Powapply_rel_def
  by simp

is_iff_rel for "Powapply"
  using Pow_rel_iff
  unfolding is_Powapply_def Powapply_rel_def
  by simp

end ―‹locale‹M_basic››

definition
  HVfrom :: "[i,i,i] ⇒ i" where
  "HVfrom(A,x,f) ≡ A ∪ (⋃y∈x. Powapply(f,y))"

relativize functional "HVfrom" "HVfrom_rel"
relationalize "HVfrom_rel" "is_HVfrom"
synthesize "is_HVfrom" from_definition assuming "nonempty"
arity_theorem intermediate for "is_HVfrom_fm"

lemma arity_is_HVfrom_fm:
  "A ∈ nat ⟹
    x ∈ nat ⟹
    f ∈ nat ⟹
    d ∈ nat ⟹
    arity(is_HVfrom_fm(A, x, f, d)) = succ(A) ∪ succ(d) ∪ (succ(x) ∪ succ(f))"
  using arity_is_HVfrom_fm' arity_is_Powapply_fm
  by(simp,subst arity_Replace_fm[of "is_Powapply_fm(succ(succ(succ(succ(f)))), 0, 1)" "succ(succ(x))" 1])
    (simp_all, auto simp add:arity pred_Un_distrib)

notation HVfrom_rel (‹HVfrom⇗_⇖'(_,_,_')›)

locale M_HVfrom = M_eclose +
  assumes
    Powapply_replacement:
    "M(f) ⟹ strong_replacement(M,λy z. z = Powapply⇗M⇖(f,y))"
begin

is_iff_rel for "HVfrom"
proof -
  assume assms:"M(A)" "M(x)" "M(f)" "M(res)"
  then
  have "is_Replace(M,x,λy z. z = Powapply⇗M⇖(f,y),r) ⟷ r = {z . y∈x, z = Powapply⇗M⇖(f,y)}"
    if "M(r)" for r
    using that Powapply_rel_closed
      Replace_abs[of x r "λy z. z = Powapply⇗M⇖(f,y)"] transM[of _ x]
    by simp
  moreover
  have "is_Replace(M,x,is_Powapply(M,f),r) ⟷
        is_Replace(M,x,λy z. z = Powapply⇗M⇖(f,y),r)" if "M(r)" for r
    using assms that is_Powapply_iff is_Replace_cong
    by simp
  ultimately
  have "is_Replace(M,x,is_Powapply(M,f),r) ⟷ r = {z . y∈x, z = Powapply⇗M⇖(f,y)}"
    if "M(r)" for r
    using that assms
    by simp
  moreover
  have "M({z . y ∈ x, z = Powapply⇗M⇖(f,y)})"
    using assms strong_replacement_closed[OF Powapply_replacement]
      Powapply_rel_closed transM[of _ x]
    by simp
  moreover from assms
    ― ‹intermediate step for body of Replace›
  have "{z . y ∈ x, z = Powapply⇗M⇖(f,y)} = {y . w ∈ x, M(y) ∧ M(w) ∧ y = Powapply⇗M⇖(f,w)}"
    by (auto dest:transM)
  ultimately
  show ?thesis
    using assms
    unfolding is_HVfrom_def HVfrom_rel_def
    by (auto dest:transM)
qed

rel_closed for "HVfrom"
proof -
  assume assms:"M(A)" "M(x)" "M(f)"
  have "M({z . y ∈ x, z = Powapply⇗M⇖(f,y)})"
    using assms strong_replacement_closed[OF Powapply_replacement]
      Powapply_rel_closed transM[of _ x]
    by simp
  then
  have "M(A ∪ ⋃({z . y∈x, z = Powapply⇗M⇖(f,y)}))"
    using assms
    by simp
  moreover from assms
    ― ‹intermediate step for body of Replace›
  have "{z . y ∈ x, z = Powapply⇗M⇖(f,y)} = {y . w ∈ x, M(y) ∧ M(w) ∧ y = Powapply⇗M⇖(f,w)}"
    by (auto dest:transM)
  ultimately
  show ?thesis
    using assms
    unfolding HVfrom_rel_def
    by simp
qed

end ― ‹locale‹M_HVfrom››

definition
  Vfrom_rel :: "[i⇒o,i,i] ⇒ i" (‹Vfrom⇗_⇖'(_,_')›) where
  "Vfrom⇗M⇖(A,i) = transrec(i, HVfrom_rel(M,A))"

definition
  is_Vfrom :: "[i⇒o,i,i,i] ⇒ o" where
  "is_Vfrom(M,A,i,z) ≡ is_transrec(M,is_HVfrom(M,A),i,z)"

definition
  Hrank :: "[i,i] ⇒ i" where
  "Hrank(x,f) ≡ (⋃y∈x. succ(f`y))"

definition
  rrank :: "i ⇒ i" where
  "rrank(a) ≡ Memrel(eclose({a}))^+"

relativize functional "Hrank" "Hrank_rel"
relationalize "Hrank_rel" "is_Hrank"
synthesize "is_Hrank" from_definition assuming "nonempty"

lemma arity_is_Hrank_fm : "x ∈ nat ⟹
    f ∈ nat ⟹
    d ∈ nat ⟹
    arity(is_Hrank_fm(x, f, d)) =
    succ(d) ∪ succ(x) ∪ succ(f)"
  unfolding is_Hrank_fm_def
  using  arity_fun_apply_fm arity_big_union_fm
    arity_fun_apply_fm arity_succ_fm arity_And arity_Exists
    arity_Replace_fm[of
      "(⋅∃⋅⋅succ(0) is 2⋅ ∧ ⋅ succ(succ(succ(succ(f))))`1 is 0⋅⋅⋅)"
      "succ(x)" 0 "4+ωf"]
  by(simp_all add:Un_assoc pred_Un,simp add:ord_simp_union)

locale M_Vfrom = M_HVfrom +
  assumes
    trepl_HVfrom : "⟦ M(A);M(i) ⟧ ⟹ transrec_replacement(M,is_HVfrom(M,A),i)"
    and
    Hrank_replacement : "M(f) ⟹ strong_replacement(M,λx y . y = succ(f`x))"
    and
    is_Hrank_replacement : "M(x) ⟹ wfrec_replacement(M,is_Hrank(M),rrank(x))"
    and
    HVfrom_replacement : "⟦ M(i) ; M(A) ⟧ ⟹
                          transrec_replacement(M,is_HVfrom(M,A),i)"

begin

lemma Vfrom_rel_iff :
  assumes "M(A)" "M(i)" "M(z)" "Ord(i)"
  shows "is_Vfrom(M,A,i,z) ⟷ z = Vfrom⇗M⇖(A,i)"
proof -
  have "relation2(M, is_HVfrom(M, A), HVfrom_rel(M, A))"
    using assms is_HVfrom_iff
    unfolding relation2_def
    by simp
  then
  show ?thesis
    using assms HVfrom_rel_closed trepl_HVfrom
      transrec_abs[of "is_HVfrom(M,A)" i "HVfrom_rel(M,A)" z]
    unfolding is_Vfrom_def Vfrom_rel_def
    by simp
qed

lemma relation2_HVfrom: "M(A) ⟹ relation2(M,is_HVfrom(M,A),HVfrom_rel(M,A))"
  using is_HVfrom_iff
  unfolding relation2_def
  by auto

lemma HVfrom_closed :
  "M(A) ⟹ ∀x[M]. ∀g[M]. function(g) ⟶ M(HVfrom_rel(M,A,x,g))"
  using HVfrom_rel_closed by simp

lemma Vfrom_rel_closed:
  assumes "M(A)" "M(i)" "Ord(i)"
  shows "M(transrec(i, HVfrom_rel(M, A)))"
  using is_HVfrom_iff HVfrom_closed HVfrom_replacement assms trepl_HVfrom relation2_HVfrom
    transrec_closed[of "is_HVfrom(M,A)" i "HVfrom_rel(M,A)"]
  by simp

lemma transrec_HVfrom:
  assumes "M(A)"
  shows "Ord(i) ⟹ M(i) ⟹ {x∈Vfrom(A,i). M(x)} = transrec(i,HVfrom_rel(M,A))"
proof (induct rule:trans_induct)
  have eq:"(⋃x∈i. {x ∈ Pow(transrec(x, HVfrom_rel(M, A))) . M(x)}) =  ⋃{y . x ∈ i, y = Pow⇗M⇖(transrec(x, HVfrom_rel(M, A)))}"
    if "Ord(i)" "M(i)" for i
    using assms Pow_rel_char[OF Vfrom_rel_closed[OF ‹M(A)› transM[of _ i]]] Ord_in_Ord' that
    by auto
  case (step i)
  then
  have 0: "M(Pow⇗M⇖(transrec(x, HVfrom_rel(M, A))))" if "x∈i" for x
    using assms that transM[of _ i] Ord_in_Ord
      transrec_closed[of "is_HVfrom(M,A)" _ "HVfrom_rel(M,A)"] trepl_HVfrom relation2_HVfrom
    by auto
  have "Vfrom(A,i) = A ∪ (⋃y∈i. Pow((λx∈i. Vfrom(A, x)) ` y))"
    using def_transrec[OF Vfrom_def, of A i] by simp
  then
  have "Vfrom(A,i) = A ∪ (⋃y∈i. Pow(Vfrom(A, y)))"
    by simp
  then
  have "{x∈Vfrom(A,i). M(x)} = {x∈A. M(x)} ∪ (⋃y∈i. {x∈Pow(Vfrom(A, y)). M(x)})"
    by auto
  with ‹M(A)›
  have "{x∈Vfrom(A,i). M(x)} = A ∪ (⋃y∈i. {x∈Pow(Vfrom(A, y)). M(x)})"
    by (auto intro:transM)
  also
  have "... = A ∪ (⋃y∈i. {x∈Pow({z∈Vfrom(A,y). M(z)}). M(x)})"
  proof -
    have "{x∈Pow(Vfrom(A, y)). M(x)} = {x∈Pow({z∈Vfrom(A,y). M(z)}). M(x)}"
      if "y∈i" for y by (auto intro:transM)
    then
    show ?thesis by simp
  qed
  also from step
  have " ... = A ∪ (⋃y∈i. {x∈Pow(transrec(y, HVfrom_rel(M, A))). M(x)})"
    using transM[of _ i]
    by auto
  also
  have " ... = transrec(i, HVfrom_rel(M, A))"
    using 0 step assms transM[of _ i] eq
      def_transrec[of "λy. transrec(y, HVfrom_rel(M, A))" "HVfrom_rel(M, A)" i]
    unfolding Powapply_rel_def HVfrom_rel_def
    by auto
  finally
  show ?case .
qed

lemma Vfrom_abs: "⟦ M(A); M(i); M(V); Ord(i) ⟧ ⟹ is_Vfrom(M,A,i,V) ⟷ V = {x∈Vfrom(A,i). M(x)}"
  unfolding is_Vfrom_def
  using is_HVfrom_iff
    transrec_abs[of "is_HVfrom(M,A)" i "HVfrom_rel(M,A)"] trepl_HVfrom relation2_HVfrom
    transrec_HVfrom
  by simp

lemma Vfrom_closed: "⟦ M(A); M(i); Ord(i) ⟧ ⟹ M({x∈Vfrom(A,i). M(x)})"
  unfolding is_Vfrom_def
  using is_HVfrom_iff HVfrom_closed HVfrom_replacement
    transrec_closed[of "is_HVfrom(M,A)" i "HVfrom_rel(M,A)"] trepl_HVfrom relation2_HVfrom
    transrec_HVfrom
  by simp

end ― ‹locale‹M_Vfrom››

subsection‹Formula synthesis›

context M_Vfrom
begin

rel_closed for "Hrank"
  unfolding Hrank_rel_def
  using Hrank_replacement
  by simp

is_iff_rel for "Hrank"
proof -
  assume "M(f)" "M(x)" "M(res)"
  moreover from this
  have "{a . y ∈ x, M(a) ∧ M(y) ∧ a = succ(f ` y)} = {a . y ∈ x,  a = succ(f ` y)}"
    using transM[of _ x]
    by auto
  ultimately
  show ?thesis
    unfolding is_Hrank_def Hrank_rel_def
    using Replace_abs transM[of _ x] Hrank_replacement
    by auto
qed

lemma relation2_Hrank :
  "relation2(M,is_Hrank(M),Hrank)"
  unfolding  relation2_def
proof(clarify)
  fix x f res
  assume "M(x)" "M(f)" "M(res)"
  moreover from this
  have "{a . y ∈ x, M(a) ∧ M(y) ∧ a = succ(f ` y)} = {a . y ∈ x,  a = succ(f ` y)}"
    using transM[of _ x]
    by auto
  ultimately
  show "is_Hrank(M, x, f, res) ⟷ res = Hrank(x, f)"
    unfolding  Hrank_def relation2_def
    using is_Hrank_iff[unfolded Hrank_rel_def]
    by auto
qed

lemma Hrank_closed :
  "∀x[M]. ∀g[M]. function(g) ⟶ M(Hrank(x,g))"
proof(clarify)
  fix x g
  assume "M(x)" "M(g)"
  then
  show "M(Hrank(x,g))"
    using RepFun_closed[OF Hrank_replacement] transM[of _ x]
    unfolding Hrank_def
    by auto
qed

end ―‹locale‹M_basic››

context M_eclose
begin

lemma wf_rrank : "M(x) ⟹ wf(rrank(x))"
  unfolding rrank_def using wf_trancl[OF wf_Memrel] .

lemma trans_rrank : "M(x) ⟹ trans(rrank(x))"
  unfolding rrank_def using trans_trancl .

lemma relation_rrank : "M(x) ⟹ relation(rrank(x))"
  unfolding rrank_def using relation_trancl .

lemma rrank_in_M : "M(x) ⟹ M(rrank(x))"
  unfolding rrank_def by simp

end ― ‹locale‹M_eclose››

lemma Hrank_trancl:"Hrank(y, restrict(f,Memrel(eclose({x}))-``{y}))
                  = Hrank(y, restrict(f,(Memrel(eclose({x}))^+)-``{y}))"
  unfolding Hrank_def
  using restrict_trans_eq by simp

lemma rank_trancl: "rank(x) = wfrec(rrank(x), x, Hrank)"
proof -
  have "rank(x) =  wfrec(Memrel(eclose({x})), x, Hrank)"
    (is "_ = wfrec(?r,_,_)")
    unfolding rank_def transrec_def Hrank_def by simp
  also
  have " ... = wftrec(?r^+, x, λy f. Hrank(y, restrict(f,?r-``{y})))"
    unfolding wfrec_def ..
  also
  have " ... = wftrec(?r^+, x, λy f. Hrank(y, restrict(f,(?r^+)-``{y})))"
    using Hrank_trancl by simp
  also
  have " ... =  wfrec(?r^+, x, Hrank)"
    unfolding wfrec_def using trancl_eq_r[OF relation_trancl trans_trancl] by simp
  finally
  show ?thesis unfolding rrank_def .
qed

definition
  Vset' :: "[i] ⇒ i" where
  "Vset'(A) ≡ Vfrom(0,A)"

reldb_add relational "Vfrom" "is_Vfrom"
reldb_add functional "Vfrom" "Vfrom_rel"
relativize functional "Vset'" "Vset_rel"
relationalize "Vset_rel" "is_Vset"
reldb_rem relational "Vset"
reldb_rem functional "Vset_rel"
reldb_add relational "Vset" "is_Vset"
reldb_add functional "Vset" "Vset_rel"

schematic_goal sats_is_Vset_fm_auto:
  assumes
    "i∈nat" "v∈nat" "env∈list(A)" "0∈A"
    "i < length(env)" "v < length(env)"
  shows
    "is_Vset(##A,nth(i, env),nth(v, env)) ⟷ sats(A,?ivs_fm(i,v),env)"
  unfolding is_Vset_def is_Vfrom_def
  by (insert assms; (rule sep_rules is_HVfrom_iff_sats is_transrec_iff_sats | simp)+)

synthesize "is_Vset" from_schematic "sats_is_Vset_fm_auto"
arity_theorem for "is_Vset_fm"
context M_Vfrom
begin

lemma Vset_abs: "⟦ M(i); M(V); Ord(i) ⟧ ⟹ is_Vset(M,i,V) ⟷ V = {x∈Vset(i). M(x)}"
  using Vfrom_abs unfolding is_Vset_def by simp

lemma Vset_closed: "⟦ M(i); Ord(i) ⟧ ⟹ M({x∈Vset(i). M(x)})"
  using Vfrom_closed unfolding is_Vset_def by simp

lemma rank_closed: "M(a) ⟹ M(rank(a))"
  unfolding rank_trancl
  using Hrank_closed is_Hrank_replacement relation2_Hrank
    wf_rrank relation_rrank trans_rrank rrank_in_M
    trans_wfrec_closed[of "rrank(a)" a "is_Hrank(M)"]
    transM[of _ a]
  by auto

lemma M_into_Vset:
  assumes "M(a)"
  shows "∃i[M]. ∃V[M]. ordinal(M,i) ∧ is_Vset(M,i,V) ∧ a∈V"
proof -
  let ?i="succ(rank(a))"
  from assms
  have "a∈{x∈Vfrom(0,?i). M(x)}" (is "a∈?V")
    using Vset_Ord_rank_iff by simp
  moreover from assms
  have "M(?i)"
    using rank_closed by simp
  moreover
  note ‹M(a)›
  moreover from calculation
  have "M(?V)"
    using Vfrom_closed by simp
  moreover from calculation
  have "ordinal(M,?i) ∧ is_Vfrom(M, 0, ?i, ?V) ∧ a ∈ ?V"
    using Ord_rank Vfrom_abs by simp
  ultimately
  show ?thesis
    using nonempty empty_abs
    unfolding is_Vset_def
    by blast
qed

end ― ‹locale‹M_HVfrom››

end

Theory Cardinal_Relative

section‹Relative, Choice-less Cardinal Numbers›

theory Cardinal_Relative
  imports
    Lambda_Replacement
    Univ_Relative
begin

txt‹The following command avoids that a commonly used one-letter variable be
captured by the definition of the constructible universe term‹L›.›
hide_const (open) L

txt‹We also return to the old notation for term‹sum› to preserve the old
Constructibility code.›
no_notation oadd (infixl ‹+› 65)
notation sum (infixr ‹+› 65)

definition
  Finite_rel   :: "[i⇒o,i]=>o"  where
  "Finite_rel(M,A) ≡ ∃om[M]. ∃n[M]. omega(M,om) ∧ n∈om ∧ eqpoll_rel(M,A,n)"

definition
  banach_functor :: "[i,i,i,i,i] ⇒ i" where
  "banach_functor(X,Y,f,g,W) ≡ X - g``(Y - f``W)"

definition
  is_banach_functor :: "[i⇒o,i,i,i,i,i,i]⇒o"  where
  "is_banach_functor(M,X,Y,f,g,W,b) ≡
      ∃fW[M]. ∃YfW[M]. ∃gYfW[M]. image(M,f,W,fW) ∧ setdiff(M,Y,fW,YfW) ∧
                                 image(M,g,YfW,gYfW) ∧ setdiff(M,X,gYfW,b)"


lemma (in M_basic) banach_functor_abs :
  assumes "M(X)" "M(Y)" "M(f)" "M(g)"
  shows "relation1(M,is_banach_functor(M,X,Y,f,g),banach_functor(X,Y,f,g))"
  unfolding relation1_def is_banach_functor_def banach_functor_def
  using assms
  by simp

lemma (in M_basic) banach_functor_closed:
  assumes "M(X)" "M(Y)" "M(f)" "M(g)"
  shows "∀W[M]. M(banach_functor(X,Y,f,g,W))"
  unfolding banach_functor_def using assms image_closed
  by simp

locale M_cardinals = M_ordertype + M_trancl + M_Perm + M_replacement_extra +
  assumes
    radd_separation: "M(R) ⟹ M(S) ⟹
    separation(M, λz.
      (∃x y. z = ⟨Inl(x), Inr(y)⟩) ∨
         (∃x' x. z = ⟨Inl(x'), Inl(x)⟩ ∧ ⟨x', x⟩ ∈ R) ∨
         (∃y' y. z = ⟨Inr(y'), Inr(y)⟩ ∧ ⟨y', y⟩ ∈ S))"
    and
    rmult_separation: "M(b) ⟹ M(d) ⟹ separation(M,
    λz. ∃x' y' x y. z = ⟨⟨x', y'⟩, x, y⟩ ∧ (⟨x', x⟩ ∈ b ∨ x' = x ∧ ⟨y', y⟩ ∈ d))"
    and
    banach_repl_iter: "M(X) ⟹ M(Y) ⟹ M(f) ⟹ M(g) ⟹
               strong_replacement(M, λx y. x∈nat ∧ y = banach_functor(X, Y, f, g)^x (0))"
begin

lemma rvimage_separation: "M(f) ⟹ M(r) ⟹
    separation(M, λz. ∃x y. z = ⟨x, y⟩ ∧ ⟨f ` x, f ` y⟩ ∈ r)"
  using separation_pair separation_in
    lam_replacement_Pair[THEN[5] lam_replacement_hcomp2]
    lam_replacement_constant lam_replacement_apply2[THEN[5] lam_replacement_hcomp2,OF lam_replacement_constant[of f]]
    lam_replacement_fst lam_replacement_snd
    lam_replacement_identity lam_replacement_hcomp
  by(simp_all)

lemma radd_closed[intro,simp]: "M(a) ⟹ M(b) ⟹ M(c) ⟹ M(d) ⟹ M(radd(a,b,c,d))"
  using radd_separation by (auto simp add: radd_def)

lemma rmult_closed[intro,simp]: "M(a) ⟹ M(b) ⟹ M(c) ⟹ M(d) ⟹ M(rmult(a,b,c,d))"
  using rmult_separation by (auto simp add: rmult_def)

end ― ‹locale‹M_cardinals››

lemma (in M_cardinals) is_cardinal_iff_Least:
  assumes "M(A)" "M(κ)"
  shows "is_cardinal(M,A,κ) ⟷ κ = (μ i. M(i) ∧ i ≈⇗M⇖ A)"
  using is_cardinal_iff assms
  unfolding cardinal_rel_def by simp

subsection‹The Schroeder-Bernstein Theorem›
text‹See Davey and Priestly, page 106›

context M_cardinals
begin

(** Lemma: Banach's Decomposition Theorem **)

lemma bnd_mono_banach_functor: "bnd_mono(X, banach_functor(X,Y,f,g))"
  unfolding bnd_mono_def banach_functor_def
  by blast

lemma inj_Inter:
  assumes "g ∈ inj(Y,X)" "A≠0" "∀a∈A. a ⊆ Y"
  shows "g``(⋂A) = (⋂a∈A. g``a)"
proof (intro equalityI subsetI)
  fix x
  from assms
  obtain a where "a∈A" by blast
  moreover
  assume "x ∈ (⋂a∈A. g `` a)"
  ultimately
  have x_in_im: "x ∈ g``y" if "y∈A" for y
    using that by auto
  have exists: "∃z ∈ y. x = g`z" if "y∈A" for y
  proof -
    note that
    moreover from this and x_in_im
    have "x ∈ g``y" by simp
    moreover from calculation
    have "x ∈ g``y" by simp
    moreover
    note assms
    ultimately
    show ?thesis
      using image_fun[OF inj_is_fun] by auto
  qed
  with ‹a∈A›
  obtain z where "z ∈ a" "x = g`z" by auto
  moreover
  have "z ∈ y" if "y∈A" for y
  proof -
    from that and exists
    obtain w where "w ∈ y" "x = g`w" by auto
    moreover from this ‹x = g`z› assms that ‹a∈A› ‹z∈a›
    have "z = w" unfolding inj_def by blast
    ultimately
    show ?thesis by simp
  qed
  moreover
  note assms
  moreover from calculation
  have "z ∈ ⋂A" by auto
  moreover from calculation
  have "z ∈ Y" by blast
  ultimately
  show "x ∈ g `` (⋂A)"
    using inj_is_fun[THEN funcI, of g] by fast
qed auto

lemma contin_banach_functor:
  assumes "g ∈ inj(Y,X)"
  shows "contin(banach_functor(X,Y,f,g))"
  unfolding contin_def
proof (intro allI impI)
  fix A
  assume "directed(A)"
  then
  have "A ≠ 0"
    unfolding directed_def ..
  have "banach_functor(X, Y, f, g, ⋃A) = X - g``(Y - f``(⋃A))"
    unfolding banach_functor_def ..
  also
  have " … = X - g``(Y - (⋃a∈A. f``a))"
    by auto
  also from ‹A≠0›
  have " … = X - g``(⋂a∈A. Y-f``a)"
    by auto
  also from ‹A≠0› and assms
  have " … = X - (⋂a∈A. g``(Y-f``a))"
    using inj_Inter[of g Y X "{Y-f``a. a∈A}" ] by fastforce
  also from ‹A≠0›
  have " … = (⋃a∈A. X - g``(Y-f``a))" by simp
  also
  have " … = (⋃a∈A. banach_functor(X, Y, f, g, a))"
    unfolding banach_functor_def ..
  finally
  show "banach_functor(X,Y,f,g,⋃A) = (⋃a∈A. banach_functor(X,Y,f,g,a))" .
qed

lemma lfp_banach_functor:
  assumes "g∈inj(Y,X)"
  shows "lfp(X, banach_functor(X,Y,f,g)) =
       (⋃n∈nat. banach_functor(X,Y,f,g)^n (0))"
  using assms lfp_eq_Union bnd_mono_banach_functor contin_banach_functor
  by simp

lemma lfp_banach_functor_closed:
  assumes "M(g)" "M(X)" "M(Y)" "M(f)" "g∈inj(Y,X)"
  shows "M(lfp(X, banach_functor(X,Y,f,g)))"
proof -
  from assms
  have "M(banach_functor(X,Y,f,g)^n (0))" if "n∈nat" for n
    by(rule_tac nat_induct[OF that],simp_all add:banach_functor_closed)
  with assms
  show ?thesis
    using family_union_closed'[OF banach_repl_iter M_nat] lfp_banach_functor
    by simp
qed

lemma banach_decomposition_rel:
  "[| M(f); M(g); M(X); M(Y); f ∈ X->Y;  g ∈ inj(Y,X) |] ==>
      ∃XA[M]. ∃XB[M]. ∃YA[M]. ∃YB[M].
         (XA ∩ XB = 0) & (XA ∪ XB = X) &
         (YA ∩ YB = 0) & (YA ∪ YB = Y) &
         f``XA=YA & g``YB=XB"
  apply (intro rexI conjI)
           apply (rule_tac [6] Banach_last_equation)
           apply (rule_tac [5] refl)
          apply (assumption |
      rule inj_is_fun Diff_disjoint Diff_partition fun_is_rel
      image_subset lfp_subset)+
  using lfp_banach_functor_closed[of g X Y f]
  unfolding banach_functor_def by simp_all

lemma schroeder_bernstein_closed:
  "[| M(f); M(g); M(X); M(Y); f ∈ inj(X,Y);  g ∈ inj(Y,X) |] ==> ∃h[M]. h ∈ bij(X,Y)"
  apply (insert banach_decomposition_rel [of f g X Y])
  apply (simp add: inj_is_fun)
  apply (auto)
  apply (rule_tac x="restrict(f,XA) ∪ converse(restrict(g,YB))" in rexI)
   apply (auto intro!: restrict_bij bij_disjoint_Un intro: bij_converse_bij)
  done

(** Equipollence is an equivalence relation **)

lemma mem_Pow_rel: "M(r) ⟹ a ∈ Pow_rel(M,r) ⟹ a ∈ Pow(r) ∧ M(a)"
  using Pow_rel_char by simp

lemma mem_bij_abs[simp]: "⟦M(f);M(A);M(B)⟧ ⟹  f ∈ bij⇗M⇖(A,B) ⟷ f∈bij(A,B)"
  using bij_rel_char by simp

lemma mem_inj_abs[simp]: "⟦M(f);M(A);M(B)⟧ ⟹  f ∈ inj⇗M⇖(A,B) ⟷ f∈inj(A,B)"
  using inj_rel_char by simp

lemma mem_surj_abs: "⟦M(f);M(A);M(B)⟧ ⟹  f ∈ surj⇗M⇖(A,B) ⟷ f∈surj(A,B)"
  using surj_rel_char by simp

lemma bij_imp_eqpoll_rel:
  assumes "f ∈ bij(A,B)" "M(f)" "M(A)" "M(B)"
  shows "A ≈⇗M⇖ B"
  using assms by (auto simp add:def_eqpoll_rel)

lemma eqpoll_rel_refl: "M(A) ⟹ A ≈⇗M⇖ A"
  using bij_imp_eqpoll_rel[OF id_bij, OF id_closed] .

lemma eqpoll_rel_sym: "X ≈⇗M⇖ Y ⟹ M(X) ⟹ M(Y) ⟹  Y ≈⇗M⇖ X"
  unfolding def_eqpoll_rel using converse_closed
  by (auto intro: bij_converse_bij)

lemma eqpoll_rel_trans [trans]:
  "[|X ≈⇗M⇖ Y;  Y ≈⇗M⇖ Z;  M(X); M(Y) ; M(Z) |] ==> X ≈⇗M⇖ Z"
  unfolding def_eqpoll_rel by (auto intro: comp_bij)

(** Le-pollence is a partial ordering **)

lemma subset_imp_lepoll_rel: "X ⊆ Y ⟹ M(X) ⟹ M(Y) ⟹ X ≲⇗M⇖ Y"
  unfolding def_lepoll_rel using id_subset_inj id_closed
  by simp blast

lemmas lepoll_rel_refl = subset_refl [THEN subset_imp_lepoll_rel, simp]

lemmas le_imp_lepoll_rel = le_imp_subset [THEN subset_imp_lepoll_rel]

lemma eqpoll_rel_imp_lepoll_rel: "X ≈⇗M⇖ Y ==> M(X) ⟹ M(Y) ⟹ X ≲⇗M⇖ Y"
  unfolding def_eqpoll_rel bij_def def_lepoll_rel using bij_is_inj
  by (auto)

lemma lepoll_rel_trans [trans]:
  assumes
    "X ≲⇗M⇖ Y" "Y ≲⇗M⇖ Z" "M(X)" "M(Y)" "M(Z)"
  shows
    "X ≲⇗M⇖ Z"
  using assms def_lepoll_rel
  by (auto intro: comp_inj)

lemma eq_lepoll_rel_trans [trans]:
  assumes
    "X ≈⇗M⇖ Y"  "Y ≲⇗M⇖ Z" "M(X)" "M(Y)" "M(Z)"
  shows
    "X ≲⇗M⇖ Z"
  using assms
  by (blast intro: eqpoll_rel_imp_lepoll_rel lepoll_rel_trans)

lemma lepoll_rel_eq_trans [trans]:
  assumes "X ≲⇗M⇖ Y"  "Y ≈⇗M⇖ Z" "M(X)" "M(Y)" "M(Z)"
  shows "X ≲⇗M⇖ Z"
  using assms
    eqpoll_rel_imp_lepoll_rel[of Y Z] lepoll_rel_trans[of X Y Z]
  by simp

lemma eqpoll_relI: "⟦ X ≲⇗M⇖ Y; Y ≲⇗M⇖ X; M(X) ; M(Y) ⟧ ⟹ X ≈⇗M⇖ Y"
  unfolding def_lepoll_rel def_eqpoll_rel using schroeder_bernstein_closed
  by auto

lemma eqpoll_relE:
  "[| X ≈⇗M⇖ Y; [| X ≲⇗M⇖ Y; Y ≲⇗M⇖ X |] ==> P ;  M(X) ; M(Y) |] ==> P"
  by (blast intro: eqpoll_rel_imp_lepoll_rel eqpoll_rel_sym)

lemma eqpoll_rel_iff: "M(X) ⟹ M(Y) ⟹ X ≈⇗M⇖ Y ⟷ X ≲⇗M⇖ Y & Y ≲⇗M⇖ X"
  by (blast intro: eqpoll_relI elim: eqpoll_relE)

lemma lepoll_rel_0_is_0: "A ≲⇗M⇖ 0 ⟹ M(A) ⟹ A = 0"
  using def_lepoll_rel
  by (cases "A=0") (auto simp add: inj_def)

(* term‹M(Y) ⟹ 0 ≲M Y› *)
lemmas empty_lepoll_relI = empty_subsetI [THEN subset_imp_lepoll_rel, OF nonempty]

lemma lepoll_rel_0_iff: "M(A) ⟹ A ≲⇗M⇖ 0 ⟷ A=0"
  by (blast intro: lepoll_rel_0_is_0 lepoll_rel_refl)

lemma Un_lepoll_rel_Un:
  "[| A ≲⇗M⇖ B; C ≲⇗M⇖ D; B ∩ D = 0; M(A); M(B); M(C); M(D) |] ==> A ∪ C ≲⇗M⇖ B ∪ D"
  using def_lepoll_rel using inj_disjoint_Un[of _ A B _ C D] if_then_replacement
  apply (auto)
  apply (rule, assumption)
  apply (auto intro!:lam_closed elim:transM)+
  done

lemma eqpoll_rel_0_is_0: "A ≈⇗M⇖ 0 ⟹ M(A) ⟹ A = 0"
  using eqpoll_rel_imp_lepoll_rel lepoll_rel_0_is_0 nonempty
  by blast

lemma eqpoll_rel_0_iff: "M(A) ⟹ A ≈⇗M⇖ 0 ⟷ A=0"
  by (blast intro: eqpoll_rel_0_is_0 eqpoll_rel_refl)

lemma eqpoll_rel_disjoint_Un:
  "[| A ≈⇗M⇖ B;  C ≈⇗M⇖ D;  A ∩ C = 0;  B ∩ D = 0; M(A); M(B); M(C) ; M(D) |]
     ==> A ∪ C ≈⇗M⇖ B ∪ D"
  by (auto intro: bij_disjoint_Un simp add:def_eqpoll_rel)

subsection‹lesspoll\_rel: contributions by Krzysztof Grabczewski›

lemma lesspoll_rel_not_refl: "M(i) ⟹ ~ (i ≺⇗M⇖ i)"
  by (simp add: lesspoll_rel_def eqpoll_rel_refl)

lemma lesspoll_rel_irrefl: "i ≺⇗M⇖ i ==> M(i) ⟹ P"
  by (simp add: lesspoll_rel_def eqpoll_rel_refl)

lemma lesspoll_rel_imp_lepoll_rel: "⟦A ≺⇗M⇖ B; M(A); M(B)⟧⟹ A ≲⇗M⇖ B"
  by (unfold lesspoll_rel_def, blast)

lemma rvimage_closed [intro,simp]:
  assumes
    "M(A)" "M(f)" "M(r)"
  shows
    "M(rvimage(A,f,r))"
  unfolding rvimage_def using assms rvimage_separation by auto

lemma lepoll_rel_well_ord: "[| A ≲⇗M⇖ B; well_ord(B,r); M(A); M(B); M(r) |] ==> ∃s[M]. well_ord(A,s)"
  unfolding def_lepoll_rel by (auto intro:well_ord_rvimage)

lemma lepoll_rel_iff_leqpoll_rel: "⟦M(A); M(B)⟧ ⟹ A ≲⇗M⇖ B ⟷ A ≺⇗M⇖ B | A ≈⇗M⇖ B"
  apply (unfold lesspoll_rel_def)
  apply (blast intro: eqpoll_relI elim: eqpoll_relE)
  done

end ― ‹locale‹M_cardinals››

context M_cardinals
begin

lemma inj_rel_is_fun_M: "f ∈ inj⇗M⇖(A,B) ⟹ M(f) ⟹ M(A) ⟹ M(B) ⟹ f ∈ A →⇗M⇖ B"
  using inj_is_fun function_space_rel_char by simp

― ‹In porting the following theorem, I tried to follow the Discipline
strictly, though finally only an approach maximizing the use of
absoluteness results (@{thm function_space_rel_char inj_rel_char}) was
 the one paying dividends.›
lemma inj_rel_not_surj_rel_succ:
  notes mem_inj_abs[simp del]
  assumes fi: "f ∈ inj⇗M⇖(A, succ(m))" and fns: "f ∉ surj⇗M⇖(A, succ(m))"
    and types: "M(f)" "M(A)" "M(m)"
  shows "∃f[M]. f ∈ inj⇗M⇖(A,m)"
proof -
  from fi [THEN inj_rel_is_fun_M] fns types
  obtain y where y: "y ∈ succ(m)" "⋀x. x∈A ⟹ f ` x ≠ y" "M(y)"
    by (auto simp add: def_surj_rel)
  show ?thesis
  proof
    from types and ‹M(y)›
    show "M(λz∈A. if f ` z = m then y else f ` z)"
      using transM[OF _ ‹M(A)›] lam_if_then_apply_replacement2 lam_replacement_iff_lam_closed
      by (auto)
    with types y fi
    have "(λz∈A. if f`z = m then y else f`z) ∈ A→⇗M⇖ m"
      using function_space_rel_char inj_rel_char inj_is_fun[of f A "succ(m)"]
      by (auto intro!: if_type [THEN lam_type] dest: apply_funtype)
    with types y fi
    show "(λz∈A. if f`z = m then y else f`z) ∈ inj⇗M⇖(A, m)"
      by (simp add: def_inj_rel) blast
  qed
qed

(** Variations on transitivity **)

lemma lesspoll_rel_trans [trans]:
  "[| X ≺⇗M⇖ Y; Y ≺⇗M⇖ Z; M(X); M(Y) ; M(Z) |] ==> X ≺⇗M⇖ Z"
  apply (unfold lesspoll_rel_def)
  apply (blast elim: eqpoll_relE intro: eqpoll_relI lepoll_rel_trans)
  done

lemma lesspoll_rel_trans1 [trans]:
  "[| X ≲⇗M⇖ Y; Y ≺⇗M⇖ Z; M(X); M(Y) ; M(Z) |] ==> X ≺⇗M⇖ Z"
  apply (unfold lesspoll_rel_def)
  apply (blast elim: eqpoll_relE intro: eqpoll_relI lepoll_rel_trans)
  done

lemma lesspoll_rel_trans2 [trans]:
  "[|  X ≺⇗M⇖ Y; Y ≲⇗M⇖ Z; M(X); M(Y) ; M(Z)|] ==> X ≺⇗M⇖ Z"
  apply (unfold lesspoll_rel_def)
  apply (blast elim: eqpoll_relE intro: eqpoll_relI lepoll_rel_trans)
  done

lemma eq_lesspoll_rel_trans [trans]:
  "[| X ≈⇗M⇖ Y; Y ≺⇗M⇖ Z; M(X); M(Y) ; M(Z) |] ==> X ≺⇗M⇖ Z"
  by (blast intro: eqpoll_rel_imp_lepoll_rel lesspoll_rel_trans1)

lemma lesspoll_rel_eq_trans [trans]:
  "[| X ≺⇗M⇖ Y; Y ≈⇗M⇖ Z; M(X); M(Y) ; M(Z) |] ==> X ≺⇗M⇖ Z"
  by (blast intro: eqpoll_rel_imp_lepoll_rel lesspoll_rel_trans2)

lemma is_cardinal_cong:
  assumes "X ≈⇗M⇖ Y" "M(X)" "M(Y)"
  shows "∃κ[M]. is_cardinal(M,X,κ) ∧ is_cardinal(M,Y,κ)"
proof -
  from assms
  have "(μ i. M(i) ∧ i ≈⇗M⇖ X) = (μ i. M(i) ∧ i ≈⇗M⇖ Y)"
    by (intro Least_cong) (auto intro: comp_bij bij_converse_bij simp add:def_eqpoll_rel)
  moreover from assms
  have "M(μ i. M(i) ∧ i ≈⇗M⇖ X)"
    using Least_closed' by fastforce
  moreover
  note assms
  ultimately
  show ?thesis
    using is_cardinal_iff_Least
    by auto
qed

― ‹ported from Cardinal›
lemma cardinal_rel_cong: "X ≈⇗M⇖ Y ⟹ M(X) ⟹ M(Y) ⟹ |X|⇗M⇖ = |Y|⇗M⇖"
  apply (simp add: def_eqpoll_rel cardinal_rel_def)
  apply (rule Least_cong)
  apply (auto intro: comp_bij bij_converse_bij)
  done

lemma well_ord_is_cardinal_eqpoll_rel:
  assumes "well_ord(A,r)" shows "is_cardinal(M,A,κ) ⟹ M(A) ⟹ M(κ) ⟹ M(r) ⟹ κ ≈⇗M⇖ A"
proof (subst is_cardinal_iff_Least[THEN iffD1, of A κ])
  assume "M(A)" "M(κ)" "M(r)" "is_cardinal(M,A,κ)"
  moreover from assms and calculation
  obtain f i where "M(f)" "Ord(i)" "M(i)" "f ∈ bij(A,i)"
    using ordertype_exists[of A r] ord_iso_is_bij by auto
  moreover
  have "M(μ i. M(i) ∧ i ≈⇗M⇖ A)"
    using Least_closed' by fastforce
  ultimately
  show "(μ i. M(i) ∧ i ≈⇗M⇖ A) ≈⇗M⇖ A"
    using assms[THEN well_ord_imp_relativized]
      LeastI[of "λi. M(i) ∧ i ≈⇗M⇖ A" i] Ord_ordertype[OF assms]
      bij_converse_bij[THEN bij_imp_eqpoll_rel, of f] by simp
qed

lemmas Ord_is_cardinal_eqpoll_rel = well_ord_Memrel[THEN well_ord_is_cardinal_eqpoll_rel]


(**********************************************************************)
(****************** Results imported from Cardinal.thy ****************)
(**********************************************************************)

section‹Porting from theory‹ZF.Cardinal››

txt‹The following results were ported more or less directly from theory‹ZF.Cardinal››

― ‹This result relies on various closure properties and
   thus cannot be translated directly›
lemma well_ord_cardinal_rel_eqpoll_rel:
  assumes r: "well_ord(A,r)" and "M(A)" "M(r)" shows "|A|⇗M⇖ ≈⇗M⇖ A"
  using assms well_ord_is_cardinal_eqpoll_rel is_cardinal_iff
  by blast

lemmas Ord_cardinal_rel_eqpoll_rel = well_ord_Memrel[THEN well_ord_cardinal_rel_eqpoll_rel]

lemma Ord_cardinal_rel_idem: "Ord(A) ⟹ M(A) ⟹ ||A|⇗M⇖|⇗M⇖ = |A|⇗M⇖"
  by (rule_tac Ord_cardinal_rel_eqpoll_rel [THEN cardinal_rel_cong]) auto

lemma well_ord_cardinal_rel_eqE:
  assumes woX: "well_ord(X,r)" and woY: "well_ord(Y,s)" and eq: "|X|⇗M⇖ = |Y|⇗M⇖"
    and types: "M(X)" "M(r)" "M(Y)" "M(s)"
  shows "X ≈⇗M⇖ Y"
proof -
  from types
  have "X ≈⇗M⇖ |X|⇗M⇖" by (blast intro: well_ord_cardinal_rel_eqpoll_rel [OF woX] eqpoll_rel_sym)
  also
  have "... = |Y|⇗M⇖" by (rule eq)
  also from types
  have "... ≈⇗M⇖ Y" by (rule_tac well_ord_cardinal_rel_eqpoll_rel [OF woY])
  finally show ?thesis  by (simp add:types)
qed

lemma well_ord_cardinal_rel_eqpoll_rel_iff:
  "[| well_ord(X,r);  well_ord(Y,s); M(X); M(r); M(Y); M(s) |] ==> |X|⇗M⇖ = |Y|⇗M⇖ ⟷ X ≈⇗M⇖ Y"
  by (blast intro: cardinal_rel_cong well_ord_cardinal_rel_eqE)

lemma Ord_cardinal_rel_le: "Ord(i) ⟹ M(i) ==> |i|⇗M⇖ ≤ i"
  unfolding cardinal_rel_def
  using eqpoll_rel_refl Least_le by simp

lemma Card_rel_cardinal_rel_eq: "Card⇗M⇖(K) ==> M(K) ⟹ |K|⇗M⇖ = K"
  apply (unfold Card_rel_def)
  apply (erule sym)
  done

lemma Card_relI: "[| Ord(i);  !!j. j<i ⟹ M(j) ==> ~(j ≈⇗M⇖ i); M(i) |] ==> Card⇗M⇖(i)"
  apply (unfold Card_rel_def cardinal_rel_def)
  apply (subst Least_equality)
     apply (blast intro: eqpoll_rel_refl)+
  done

lemma Card_rel_is_Ord: "Card⇗M⇖(i) ==> M(i) ⟹ Ord(i)"
  apply (unfold Card_rel_def cardinal_rel_def)
  apply (erule ssubst)
  apply (rule Ord_Least)
  done

lemma Card_rel_cardinal_rel_le: "Card⇗M⇖(K) ==> M(K) ⟹ K ≤ |K|⇗M⇖"
  apply (simp (no_asm_simp) add: Card_rel_is_Ord Card_rel_cardinal_rel_eq)
  done

lemma Ord_cardinal_rel [simp,intro!]: "M(A) ⟹ Ord(|A|⇗M⇖)"
  apply (unfold cardinal_rel_def)
  apply (rule Ord_Least)
  done

lemma Card_rel_iff_initial: assumes types:"M(K)"
  shows "Card⇗M⇖(K) ⟷ Ord(K) & (∀j[M]. j<K ⟶ ~ (j ≈⇗M⇖ K))"
proof -
  { fix j
    assume K: "Card⇗M⇖(K)" "M(j) ∧ j ≈⇗M⇖ K"
    assume "j < K"
    also have "... = (μ i. M(i) ∧ i ≈⇗M⇖ K)" using K
      by (simp add: Card_rel_def cardinal_rel_def types)
    finally have "j < (μ i. M(i) ∧ i ≈⇗M⇖ K)" .
    then have "False" using K
      by (best intro: less_LeastE[of "λj. M(j) ∧ j ≈⇗M⇖ K"])
  }
  with types
  show ?thesis
    by (blast intro: Card_relI Card_rel_is_Ord)
qed

lemma lt_Card_rel_imp_lesspoll_rel: "[| Card⇗M⇖(a); i<a; M(a); M(i) |] ==> i ≺⇗M⇖ a"
  apply (unfold lesspoll_rel_def)
  apply (frule Card_rel_iff_initial [THEN iffD1], assumption)
  apply (blast intro!: leI [THEN le_imp_lepoll_rel])
  done

lemma Card_rel_0: "Card⇗M⇖(0)"
  apply (rule Ord_0 [THEN Card_relI])
   apply (auto elim!: ltE)
  done

lemma Card_rel_Un: "[| Card⇗M⇖(K);  Card⇗M⇖(L); M(K); M(L) |] ==> Card⇗M⇖(K ∪ L)"
  apply (rule Ord_linear_le [of K L])
     apply (simp_all add: subset_Un_iff [THEN iffD1]  Card_rel_is_Ord le_imp_subset
      subset_Un_iff2 [THEN iffD1])
  done

lemma Card_rel_cardinal_rel [iff]: assumes types:"M(A)" shows "Card⇗M⇖(|A|⇗M⇖)"
  using assms
proof (unfold cardinal_rel_def)
  show "Card⇗M⇖(μ i. M(i) ∧ i ≈⇗M⇖ A)"
  proof (cases "∃i[M]. Ord (i) ∧ i ≈⇗M⇖ A")
    case False thus ?thesis           ― ‹degenerate case›
      using Least_0[of "λi. M(i) ∧ i ≈⇗M⇖ A"] Card_rel_0
      by fastforce
  next
    case True                         ― ‹real case: term‹A› is isomorphic to some ordinal›
    then obtain i where i: "Ord(i)" "i ≈⇗M⇖ A" "M(i)" by blast
    show ?thesis
    proof (rule Card_relI [OF Ord_Least], rule notI)
      fix j
      assume j: "j < (μ i. M(i) ∧ i ≈⇗M⇖ A)" and "M(j)"
      assume "j ≈⇗M⇖ (μ i. M(i) ∧ i ≈⇗M⇖ A)"
      also have "... ≈⇗M⇖ A" using i LeastI[of "λi. M(i) ∧ i ≈⇗M⇖ A"] by (auto)
      finally have "j ≈⇗M⇖ A"
        using Least_closed'[of "λi. M(i) ∧ i ≈⇗M⇖ A"] by (simp add: ‹M(j)› types)
      thus False
        using ‹M(j)› by (blast intro:less_LeastE [OF _ j])
    qed (auto intro:Least_closed)
  qed
qed

lemma cardinal_rel_eq_lemma:
  assumes i:"|i|⇗M⇖ ≤ j" and j: "j ≤ i" and types: "M(i)" "M(j)"
  shows "|j|⇗M⇖ = |i|⇗M⇖"
proof (rule eqpoll_relI [THEN cardinal_rel_cong])
  show "j ≲⇗M⇖ i" by (rule le_imp_lepoll_rel [OF j]) (simp_all add:types)
next
  have Oi: "Ord(i)" using j by (rule le_Ord2)
  with types
  have "i ≈⇗M⇖ |i|⇗M⇖"
    by (blast intro: Ord_cardinal_rel_eqpoll_rel eqpoll_rel_sym)
  also from types
  have "... ≲⇗M⇖ j"
    by (blast intro: le_imp_lepoll_rel i)
  finally show "i ≲⇗M⇖ j" by (simp_all add:types)
qed (simp_all add:types)

lemma cardinal_rel_mono:
  assumes ij: "i ≤ j" and types:"M(i)" "M(j)" shows "|i|⇗M⇖ ≤ |j|⇗M⇖"
  using Ord_cardinal_rel [OF ‹M(i)›] Ord_cardinal_rel [OF ‹M(j)›]
proof (cases rule: Ord_linear_le)
  case le then show ?thesis .
next
  case ge
  have i: "Ord(i)" using ij
    by (simp add: lt_Ord)
  have ci: "|i|⇗M⇖ ≤ j"
    by (blast intro: Ord_cardinal_rel_le ij le_trans i types)
  have "|i|⇗M⇖ = ||i|⇗M⇖|⇗M⇖"
    by (auto simp add: Ord_cardinal_rel_idem i types)
  also have "... = |j|⇗M⇖"
    by (rule cardinal_rel_eq_lemma [OF ge ci]) (simp_all add:types)
  finally have "|i|⇗M⇖ = |j|⇗M⇖" .
  thus ?thesis by (simp add:types)
qed

lemma cardinal_rel_lt_imp_lt: "[| |i|⇗M⇖ < |j|⇗M⇖;  Ord(i);  Ord(j); M(i); M(j) |] ==> i < j"
  apply (rule Ord_linear2 [of i j], assumption+)
  apply (erule lt_trans2 [THEN lt_irrefl])
  apply (erule cardinal_rel_mono, assumption+)
  done

lemma Card_rel_lt_imp_lt: "[| |i|⇗M⇖ < K;  Ord(i);  Card⇗M⇖(K); M(i); M(K)|] ==> i < K"
  by (simp (no_asm_simp) add: cardinal_rel_lt_imp_lt Card_rel_is_Ord Card_rel_cardinal_rel_eq)

lemma Card_rel_lt_iff: "[| Ord(i);  Card⇗M⇖(K); M(i); M(K) |] ==> (|i|⇗M⇖ < K) ⟷ (i < K)"
  by (blast intro: Card_rel_lt_imp_lt Ord_cardinal_rel_le [THEN lt_trans1])

lemma Card_rel_le_iff: "[| Ord(i);  Card⇗M⇖(K); M(i); M(K) |] ==> (K ≤ |i|⇗M⇖) ⟷ (K ≤ i)"
  by (simp add: Card_rel_lt_iff Card_rel_is_Ord not_lt_iff_le [THEN iff_sym])

lemma well_ord_lepoll_rel_imp_cardinal_rel_le:
  assumes wB: "well_ord(B,r)" and AB: "A ≲⇗M⇖ B"
    and
    types: "M(B)" "M(r)" "M(A)"
  shows "|A|⇗M⇖ ≤ |B|⇗M⇖"
  using Ord_cardinal_rel [OF ‹M(A)›] Ord_cardinal_rel [OF ‹M(B)›]
proof (cases rule: Ord_linear_le)
  case le thus ?thesis .
next
  case ge
  from lepoll_rel_well_ord [OF AB wB]
  obtain s where s: "well_ord(A, s)" "M(s)" by (blast intro:types)
  have "B ≈⇗M⇖ |B|⇗M⇖" by (blast intro: wB eqpoll_rel_sym well_ord_cardinal_rel_eqpoll_rel types)
  also have "... ≲⇗M⇖ |A|⇗M⇖" by (rule le_imp_lepoll_rel [OF ge]) (simp_all add:types)
  also have "... ≈⇗M⇖ A" by (rule well_ord_cardinal_rel_eqpoll_rel [OF s(1) _ s(2)]) (simp_all add:types)
  finally have "B ≲⇗M⇖ A" by (simp_all add:types)
  hence "A ≈⇗M⇖ B" by (blast intro: eqpoll_relI AB types)
  hence "|A|⇗M⇖ = |B|⇗M⇖" by (rule cardinal_rel_cong) (simp_all add:types)
  thus ?thesis by (simp_all add:types)
qed

lemma lepoll_rel_cardinal_rel_le: "[| A ≲⇗M⇖ i; Ord(i); M(A); M(i) |] ==> |A|⇗M⇖ ≤ i"
  using Memrel_closed
  apply (rule_tac le_trans)
   apply (erule well_ord_Memrel [THEN well_ord_lepoll_rel_imp_cardinal_rel_le], assumption+)
  apply (erule Ord_cardinal_rel_le, assumption)
  done

lemma lepoll_rel_Ord_imp_eqpoll_rel: "[| A ≲⇗M⇖ i; Ord(i); M(A); M(i) |] ==> |A|⇗M⇖ ≈⇗M⇖ A"
  by (blast intro: lepoll_rel_cardinal_rel_le well_ord_Memrel well_ord_cardinal_rel_eqpoll_rel dest!: lepoll_rel_well_ord)

lemma lesspoll_rel_imp_eqpoll_rel: "[| A ≺⇗M⇖ i; Ord(i); M(A); M(i) |] ==> |A|⇗M⇖ ≈⇗M⇖ A"
  using lepoll_rel_Ord_imp_eqpoll_rel[OF lesspoll_rel_imp_lepoll_rel] .

lemma lesspoll_cardinal_lt_rel:
  shows "[| A ≺⇗M⇖ i; Ord(i); M(i); M(A) |] ==> |A|⇗M⇖ < i"
proof -
  assume assms:"A ≺⇗M⇖ i" ‹Ord(i)› ‹M(i)› ‹M(A)›
  then
  have A:"Ord(|A|⇗M⇖)" "|A|⇗M⇖ ≈⇗M⇖ A" "M(|A|⇗M⇖)"
    using Ord_cardinal_rel lesspoll_rel_imp_eqpoll_rel
    by simp_all
  with assms
  have "|A|⇗M⇖ ≺⇗M⇖ i"
    using eq_lesspoll_rel_trans by auto
  consider "|A|⇗M⇖∈i" | "|A|⇗M⇖=i" | "i∈|A|⇗M⇖"
    using Ord_linear[OF ‹Ord(i)› ‹Ord(|A|⇗M⇖)›] by auto
  then
  have "|A|⇗M⇖ < i"
  proof(cases)
    case 1
    then show ?thesis using ltI ‹Ord(i)› by simp
  next
    case 2
    with ‹|A|⇗M⇖ ≺⇗M⇖ i› ‹M(i)›
    show ?thesis using lesspoll_rel_irrefl by simp
  next
    case 3
    with ‹Ord(|A|⇗M⇖)›
    have "i<|A|⇗M⇖" using ltI by simp
    with ‹M(A)› A ‹M(i)›
    have "i ≺⇗M⇖ |A|⇗M⇖"
      using lt_Card_rel_imp_lesspoll_rel Card_rel_cardinal_rel by simp
    with ‹M(|A|⇗M⇖)› ‹M(i)›
    show ?thesis
      using lesspoll_rel_irrefl lesspoll_rel_trans[OF ‹|A|⇗M⇖ ≺⇗M⇖ i› ‹i ≺⇗M⇖ _ ›]
      by simp
  qed
  then show ?thesis by simp
qed

lemma cardinal_rel_subset_Ord: "[|A<=i; Ord(i); M(A); M(i)|] ==> |A|⇗M⇖ ⊆ i"
  apply (drule subset_imp_lepoll_rel [THEN lepoll_rel_cardinal_rel_le])
       apply (auto simp add: lt_def)
  apply (blast intro: Ord_trans)
  done

― ‹The next lemma is the first with several porting issues›
lemma cons_lepoll_rel_consD:
  "[| cons(u,A) ≲⇗M⇖ cons(v,B);  u∉A;  v∉B; M(u); M(A); M(v); M(B) |] ==> A ≲⇗M⇖ B"
  apply (simp add: def_lepoll_rel, unfold inj_def, safe)
  apply (rule_tac x = "λx∈A. if f`x=v then f`u else f`x" in rexI)
   apply (rule CollectI)
    (*Proving it's in the function space A->B*)
    apply (rule if_type [THEN lam_type])
     apply (blast dest: apply_funtype)
    apply (blast elim!: mem_irrefl dest: apply_funtype)
    (*Proving it's injective*)
   apply (auto simp add:transM[of _ A])
  using lam_replacement_iff_lam_closed  lam_if_then_apply_replacement
  by simp

lemma cons_eqpoll_rel_consD: "[| cons(u,A) ≈⇗M⇖ cons(v,B);  u∉A;  v∉B; M(u); M(A); M(v); M(B) |] ==> A ≈⇗M⇖ B"
  apply (simp add: eqpoll_rel_iff)
  apply (blast intro: cons_lepoll_rel_consD)
  done

lemma succ_lepoll_rel_succD: "succ(m) ≲⇗M⇖ succ(n) ⟹ M(m) ⟹ M(n) ==> m ≲⇗M⇖ n"
  apply (unfold succ_def)
  apply (erule cons_lepoll_rel_consD)
       apply (rule mem_not_refl)+
     apply assumption+
  done

lemma nat_lepoll_rel_imp_le:
  "m ∈ nat ==> n ∈ nat ⟹ m ≲⇗M⇖ n ⟹ M(m) ⟹ M(n) ⟹ m ≤ n"
proof (induct m arbitrary: n rule: nat_induct)
  case 0 thus ?case by (blast intro!: nat_0_le)
next
  case (succ m)
  show ?case  using ‹n ∈ nat›
  proof (cases rule: natE)
    case 0 thus ?thesis using succ
      by (simp add: def_lepoll_rel inj_def)
  next
    case (succ n') thus ?thesis using succ.hyps ‹ succ(m) ≲⇗M⇖ n›
      by (blast dest!: succ_lepoll_rel_succD)
  qed
qed

lemma nat_eqpoll_rel_iff: "[| m ∈ nat; n ∈ nat; M(m); M(n) |] ==> m ≈⇗M⇖ n ⟷ m = n"
  apply (rule iffI)
   apply (blast intro: nat_lepoll_rel_imp_le le_anti_sym elim!: eqpoll_relE)
  apply (simp add: eqpoll_rel_refl)
  done

lemma nat_into_Card_rel:
  assumes n: "n ∈ nat" and types: "M(n)" shows "Card⇗M⇖(n)"
  using types
  apply (subst Card_rel_def)
proof (unfold cardinal_rel_def, rule sym)
  have "Ord(n)" using n  by auto
  moreover
  { fix i
    assume "i < n" "M(i)" "i ≈⇗M⇖ n"
    hence False using n
      by (auto simp add: lt_nat_in_nat [THEN nat_eqpoll_rel_iff] types)
  }
  ultimately show "(μ i. M(i) ∧ i ≈⇗M⇖ n) = n" by (auto intro!: Least_equality types eqpoll_rel_refl)
qed

lemmas cardinal_rel_0 = nat_0I [THEN nat_into_Card_rel, THEN Card_rel_cardinal_rel_eq, simplified, iff]
lemmas cardinal_rel_1 = nat_1I [THEN nat_into_Card_rel, THEN Card_rel_cardinal_rel_eq, simplified, iff]

lemma succ_lepoll_rel_natE: "[| succ(n) ≲⇗M⇖ n;  n ∈ nat |] ==> P"
  by (rule nat_lepoll_rel_imp_le [THEN lt_irrefl], auto)

lemma nat_lepoll_rel_imp_ex_eqpoll_rel_n:
  "[| n ∈ nat;  nat ≲⇗M⇖ X ; M(n); M(X)|] ==> ∃Y[M]. Y ⊆ X & n ≈⇗M⇖ Y"
  apply (simp add: def_lepoll_rel def_eqpoll_rel)
  apply (fast del: subsetI subsetCE
      intro!: subset_SIs
      dest!: Ord_nat [THEN [2] OrdmemD, THEN [2] restrict_inj]
      elim!: restrict_bij
      inj_is_fun [THEN fun_is_rel, THEN image_subset])
  done

lemma lepoll_rel_succ: "M(i) ⟹ i ≲⇗M⇖ succ(i)"
  by (blast intro: subset_imp_lepoll_rel)

lemma lepoll_rel_imp_lesspoll_rel_succ:
  assumes A: "A ≲⇗M⇖ m" and m: "m ∈ nat"
    and types: "M(A)" "M(m)"
  shows "A ≺⇗M⇖ succ(m)"
proof -
  { assume "A ≈⇗M⇖ succ(m)"
    hence "succ(m) ≈⇗M⇖ A" by (rule eqpoll_rel_sym) (auto simp add:types)
    also have "... ≲⇗M⇖ m" by (rule A)
    finally have "succ(m) ≲⇗M⇖ m" by (auto simp add:types)
    hence False by (rule succ_lepoll_rel_natE) (rule m) }
  moreover have "A ≲⇗M⇖ succ(m)" by (blast intro: lepoll_rel_trans A lepoll_rel_succ types)
  ultimately show ?thesis by (auto simp add: types lesspoll_rel_def)
qed

lemma lesspoll_rel_succ_imp_lepoll_rel:
  "[| A ≺⇗M⇖ succ(m); m ∈ nat; M(A); M(m) |] ==> A ≲⇗M⇖ m"
proof -
  {
    assume "m ∈ nat" "M(A)" "M(m)" "A ≲⇗M⇖ succ(m)"
      "∀f∈inj⇗M⇖(A, succ(m)). f ∉ surj⇗M⇖(A, succ(m))"
    moreover from this
    obtain f where "M(f)" "f∈inj⇗M⇖(A,succ(m))"
      using def_lepoll_rel by auto
    moreover from calculation
    have "f ∉ surj⇗M⇖(A, succ(m))" by simp
    ultimately
    have "∃f[M]. f ∈ inj⇗M⇖(A, m)"
      using inj_rel_not_surj_rel_succ by auto
  }
  from this
  show "⟦ A ≺⇗M⇖ succ(m); m ∈ nat; M(A); M(m) ⟧ ⟹ A ≲⇗M⇖ m"
    unfolding lepoll_rel_def eqpoll_rel_def bij_rel_def lesspoll_rel_def
    by (simp del:mem_inj_abs)
qed

lemma lesspoll_rel_succ_iff: "m ∈ nat ⟹ M(A) ==> A ≺⇗M⇖ succ(m) ⟷ A ≲⇗M⇖ m"
  by (blast intro!: lepoll_rel_imp_lesspoll_rel_succ lesspoll_rel_succ_imp_lepoll_rel)

lemma lepoll_rel_succ_disj: "[| A ≲⇗M⇖ succ(m);  m ∈ nat; M(A) ; M(m)|] ==> A ≲⇗M⇖ m | A ≈⇗M⇖ succ(m)"
  apply (rule disjCI)
  apply (rule lesspoll_rel_succ_imp_lepoll_rel)
     prefer 2 apply assumption
    apply (simp (no_asm_simp) add: lesspoll_rel_def, assumption+)
  done

lemma lesspoll_rel_cardinal_rel_lt: "[| A ≺⇗M⇖ i; Ord(i); M(A); M(i) |] ==> |A|⇗M⇖ < i"
  apply (unfold lesspoll_rel_def, clarify)
  apply (frule lepoll_rel_cardinal_rel_le, assumption+) ― ‹because of types›
  apply (blast intro: well_ord_Memrel well_ord_cardinal_rel_eqpoll_rel [THEN eqpoll_rel_sym]
      dest: lepoll_rel_well_ord  elim!: leE)
  done


lemma lt_not_lepoll_rel:
  assumes n: "n<i" "n ∈ nat"
    and types:"M(n)" "M(i)" shows "~ i ≲⇗M⇖ n"
proof -
  { assume i: "i ≲⇗M⇖ n"
    have "succ(n) ≲⇗M⇖ i" using n
      by (elim ltE, blast intro: Ord_succ_subsetI [THEN subset_imp_lepoll_rel] types)
    also have "... ≲⇗M⇖ n" by (rule i)
    finally have "succ(n) ≲⇗M⇖ n" by (simp add:types)
    hence False  by (rule succ_lepoll_rel_natE) (rule n) }
  thus ?thesis by auto
qed

text‹A slightly weaker version of ‹nat_eqpoll_rel_iff››
lemma Ord_nat_eqpoll_rel_iff:
  assumes i: "Ord(i)" and n: "n ∈ nat"
    and types: "M(i)" "M(n)"
  shows "i ≈⇗M⇖ n ⟷ i=n"
  using i nat_into_Ord [OF n]
proof (cases rule: Ord_linear_lt)
  case lt
  hence  "i ∈ nat" by (rule lt_nat_in_nat) (rule n)
  thus ?thesis by (simp add: nat_eqpoll_rel_iff n types)
next
  case eq
  thus ?thesis by (simp add: eqpoll_rel_refl types)
next
  case gt
  hence  "~ i ≲⇗M⇖ n" using n  by (rule lt_not_lepoll_rel) (simp_all add: types)
  hence  "~ i ≈⇗M⇖ n" using n  by (blast intro: eqpoll_rel_imp_lepoll_rel types)
  moreover have "i ≠ n" using ‹n<i› by auto
  ultimately show ?thesis by blast
qed

lemma Card_rel_nat: "Card⇗M⇖(nat)"
proof -
  { fix i
    assume i: "i < nat" "i ≈⇗M⇖ nat" "M(i)"
    hence "~ nat ≲⇗M⇖ i"
      by (simp add: lt_def lt_not_lepoll_rel)
    hence False using i
      by (simp add: eqpoll_rel_iff)
  }
  hence "(μ i. M(i) ∧ i ≈⇗M⇖ nat) = nat" by (blast intro: Least_equality eqpoll_rel_refl)
  thus ?thesis
    by (auto simp add: Card_rel_def cardinal_rel_def)
qed

lemma nat_le_cardinal_rel: "nat ≤ i ⟹ M(i) ==> nat ≤ |i|⇗M⇖"
  apply (rule Card_rel_nat [THEN Card_rel_cardinal_rel_eq, THEN subst], simp_all)
  apply (erule cardinal_rel_mono, simp_all)
  done

lemma n_lesspoll_rel_nat: "n ∈ nat ==> n ≺⇗M⇖ nat"
  by (blast intro: Card_rel_nat ltI lt_Card_rel_imp_lesspoll_rel)

lemma cons_lepoll_rel_cong:
  "[| A ≲⇗M⇖ B;  b ∉ B; M(A); M(B); M(b); M(a) |] ==> cons(a,A) ≲⇗M⇖ cons(b,B)"
  apply (subst (asm) def_lepoll_rel, simp_all, subst def_lepoll_rel, simp_all, safe)
  apply (rule_tac x = "λy∈cons (a,A) . if y=a then b else f`y" in rexI)
   apply (rule_tac d = "%z. if z ∈ B then converse (f) `z else a" in lam_injective)
    apply (safe elim!: consE')
      apply simp_all
    apply (blast intro: inj_is_fun [THEN apply_type])+
  apply (auto intro:lam_closed lam_if_then_replacement simp add:transM[of _ A])
  done

lemma cons_eqpoll_rel_cong:
  "[| A ≈⇗M⇖ B;  a ∉ A;  b ∉ B;  M(A); M(B); M(a) ; M(b) |] ==> cons(a,A) ≈⇗M⇖ cons(b,B)"
  by (simp add: eqpoll_rel_iff cons_lepoll_rel_cong)

lemma cons_lepoll_rel_cons_iff:
  "[| a ∉ A;  b ∉ B; M(a); M(A); M(b); M(B) |] ==> cons(a,A) ≲⇗M⇖ cons(b,B)  ⟷  A ≲⇗M⇖ B"
  by (blast intro: cons_lepoll_rel_cong cons_lepoll_rel_consD)

lemma cons_eqpoll_rel_cons_iff:
  "[| a ∉ A;  b ∉ B; M(a); M(A); M(b); M(B) |] ==> cons(a,A) ≈⇗M⇖ cons(b,B)  ⟷  A ≈⇗M⇖ B"
  by (blast intro: cons_eqpoll_rel_cong cons_eqpoll_rel_consD)

lemma singleton_eqpoll_rel_1: "M(a) ⟹ {a} ≈⇗M⇖ 1"
  apply (unfold succ_def)
  apply (blast intro!: eqpoll_rel_refl [THEN cons_eqpoll_rel_cong])
  done

lemma cardinal_rel_singleton: "M(a) ⟹ |{a}|⇗M⇖ = 1"
  apply (rule singleton_eqpoll_rel_1 [THEN cardinal_rel_cong, THEN trans])
     apply (simp (no_asm) add: nat_into_Card_rel [THEN Card_rel_cardinal_rel_eq])
    apply auto
  done

lemma not_0_is_lepoll_rel_1: "A ≠ 0 ==> M(A) ⟹ 1 ≲⇗M⇖ A"
  apply (erule not_emptyE)
  apply (rule_tac a = "cons (x, A-{x}) " in subst)
   apply (rule_tac [2] a = "cons(0,0)" and P= "%y. y ≲⇗M⇖ cons (x, A-{x})" in subst)
    apply auto
proof -
  fix x
  assume "M(A)"
  then
  show "x ∈ A ⟹ {0} ≲⇗M⇖ cons(x, A - {x})"
    by (auto intro: cons_lepoll_rel_cong transM[OF _ ‹M(A)›] subset_imp_lepoll_rel)
qed


lemma succ_eqpoll_rel_cong: "A ≈⇗M⇖ B ⟹ M(A) ⟹ M(B) ==> succ(A) ≈⇗M⇖ succ(B)"
  apply (unfold succ_def)
  apply (simp add: cons_eqpoll_rel_cong mem_not_refl)
  done

text‹The next result was not straightforward to port, and even a
different statement was needed.›

lemma sum_bij_rel:
  "[| f ∈ bij⇗M⇖(A,C); g ∈ bij⇗M⇖(B,D); M(f); M(A); M(C); M(g); M(B); M(D)|]
      ==> (λz∈A+B. case(%x. Inl(f`x), %y. Inr(g`y), z)) ∈ bij⇗M⇖(A+B, C+D)"
proof -
  assume asm:"f ∈ bij⇗M⇖(A,C)" "g ∈ bij⇗M⇖(B,D)" "M(f)" "M(A)" "M(C)" "M(g)" "M(B)" "M(D)"
  then
  have "M(λz∈A+B. case(%x. Inl(f`x), %y. Inr(g`y), z))"
    using transM[OF _ ‹M(A)›] transM[OF _ ‹M(B)›]
    by (auto intro:case_replacement4[THEN lam_closed])
  with asm
  show ?thesis
    apply simp
    apply (rule_tac d = "case (%x. Inl (converse(f)`x), %y. Inr(converse(g)`y))"
        in lam_bijective)
       apply (typecheck add: bij_is_inj inj_is_fun)
     apply (auto simp add: left_inverse_bij right_inverse_bij)
    done
qed

lemma sum_bij_rel':
  assumes "f ∈ bij⇗M⇖(A,C)" "g ∈ bij⇗M⇖(B,D)" "M(f)"
    "M(A)" "M(C)" "M(g)" "M(B)" "M(D)"
  shows
    "(λz∈A+B. case(λx. Inl(f`x), λy. Inr(g`y), z)) ∈ bij(A+B, C+D)"
    "M(λz∈A+B. case(λx. Inl(f`x), λy. Inr(g`y), z))"
proof -
  from assms
  show "M(λz∈A+B. case(λx. Inl(f`x), λy. Inr(g`y), z))"
    using transM[OF _ ‹M(A)›] transM[OF _ ‹M(B)›]
    by (auto intro:case_replacement4[THEN lam_closed])
  with assms
  show "(λz∈A+B. case(λx. Inl(f`x), λy. Inr(g`y), z)) ∈ bij(A+B, C+D)"
    apply simp
    apply (rule_tac d = "case (%x. Inl (converse(f)`x), %y. Inr(converse(g)`y))"
        in lam_bijective)
       apply (typecheck add: bij_is_inj inj_is_fun)
     apply (auto simp add: left_inverse_bij right_inverse_bij)
    done
qed

lemma sum_eqpoll_rel_cong:
  assumes "A ≈⇗M⇖ C" "B ≈⇗M⇖ D" "M(A)" "M(C)" "M(B)" "M(D)"
  shows "A+B ≈⇗M⇖ C+D"
  using assms
proof (simp add: def_eqpoll_rel, safe, rename_tac g)
  fix f g
  assume  "M(f)" "f ∈ bij(A, C)" "M(g)" "g ∈ bij(B, D)"
  with assms
  obtain h where "h∈bij(A+B, C+D)" "M(h)"
    using sum_bij_rel'[of f A C g B D] by simp
  then
  show "∃f[M]. f ∈ bij(A + B, C + D)"
    by auto
qed

lemma prod_bij_rel':
  assumes "f ∈ bij⇗M⇖(A,C)" "g ∈ bij⇗M⇖(B,D)" "M(f)"
    "M(A)" "M(C)" "M(g)" "M(B)" "M(D)"
  shows
    "(λ<x,y>∈A*B. <f`x, g`y>) ∈ bij(A*B, C*D)"
    "M(λ<x,y>∈A*B. <f`x, g`y>)"
proof -
  from assms
  show "M((λ<x,y>∈A*B. <f`x, g`y>))"
    using transM[OF _ ‹M(A)›] transM[OF _ ‹M(B)›]
      transM[OF _ cartprod_closed, of _ A B]
    by (auto intro:prod_fun_replacement[THEN lam_closed, of f g "A×B"])
  with assms
  show "(λ<x,y>∈A*B. <f`x, g`y>) ∈ bij(A*B, C*D)"
    apply simp
    apply (rule_tac d = "%<x,y>. <converse (f) `x, converse (g) `y>"
        in lam_bijective)
       apply (typecheck add: bij_is_inj inj_is_fun)
     apply (auto simp add: left_inverse_bij right_inverse_bij)
    done
qed

lemma prod_eqpoll_rel_cong:
  assumes "A ≈⇗M⇖ C" "B ≈⇗M⇖ D" "M(A)" "M(C)" "M(B)" "M(D)"
  shows "A×B ≈⇗M⇖ C×D"
  using assms
proof (simp add: def_eqpoll_rel, safe, rename_tac g)
  fix f g
  assume  "M(f)" "f ∈ bij(A, C)" "M(g)" "g ∈ bij(B, D)"
  with assms
  obtain h where "h∈bij(A×B, C×D)" "M(h)"
    using prod_bij_rel'[of f A C g B D] by simp
  then
  show "∃f[M]. f ∈ bij(A × B, C × D)"
    by auto
qed

lemma inj_rel_disjoint_eqpoll_rel:
  "[| f ∈ inj⇗M⇖(A,B);  A ∩ B = 0;M(f); M(A);M(B) |] ==> A ∪ (B - range(f)) ≈⇗M⇖ B"
  apply (simp add: def_eqpoll_rel)
  apply (rule rexI)
   apply (rule_tac c = "%x. if x ∈ A then f`x else x"
      and d = "%y. if y ∈ range (f) then converse (f) `y else y"
      in lam_bijective)
      apply (blast intro!: if_type inj_is_fun [THEN apply_type])
     apply (simp (no_asm_simp) add: inj_converse_fun [THEN apply_funtype])
    apply (safe elim!: UnE')
     apply (simp_all add: inj_is_fun [THEN apply_rangeI])
   apply (blast intro: inj_converse_fun [THEN apply_type])
proof -
  assume "f ∈ inj(A, B)" "A ∩ B = 0" "M(f)" "M(A)" "M(B)"
  then
  show "M(λx∈A ∪ (B - range(f)). if x ∈ A then f ` x else x)"
    using  transM[OF _ ‹M(A)›] transM[OF _ ‹M(B)›]
      lam_replacement_iff_lam_closed lam_if_then_replacement2
    by auto
qed

lemma Diff_sing_lepoll_rel:
  "[| a ∈ A;  A ≲⇗M⇖ succ(n); M(a); M(A); M(n) |] ==> A - {a} ≲⇗M⇖ n"
  apply (unfold succ_def)
  apply (rule cons_lepoll_rel_consD)
        apply (rule_tac [3] mem_not_refl)
       apply (erule cons_Diff [THEN ssubst], simp_all)
  done

lemma lepoll_rel_Diff_sing:
  assumes A: "succ(n) ≲⇗M⇖ A"
    and types: "M(n)" "M(A)" "M(a)"
  shows "n ≲⇗M⇖ A - {a}"
proof -
  have "cons(n,n) ≲⇗M⇖ A" using A
    by (unfold succ_def)
  also from types
  have "... ≲⇗M⇖ cons(a, A-{a})"
    by (blast intro: subset_imp_lepoll_rel)
  finally have "cons(n,n) ≲⇗M⇖ cons(a, A-{a})" by (simp_all add:types)
  with types
  show ?thesis
    by (blast intro: cons_lepoll_rel_consD mem_irrefl)
qed

lemma Diff_sing_eqpoll_rel: "[| a ∈ A; A ≈⇗M⇖ succ(n); M(a); M(A); M(n) |] ==> A - {a} ≈⇗M⇖ n"
  by (blast intro!: eqpoll_relI
      elim!: eqpoll_relE
      intro: Diff_sing_lepoll_rel lepoll_rel_Diff_sing)

lemma lepoll_rel_1_is_sing: "[| A ≲⇗M⇖ 1; a ∈ A ;M(a); M(A) |] ==> A = {a}"
  apply (frule Diff_sing_lepoll_rel, assumption+, simp)
  apply (drule lepoll_rel_0_is_0, simp)
  apply (blast elim: equalityE)
  done

lemma Un_lepoll_rel_sum: "M(A) ⟹ M(B) ⟹ A ∪ B ≲⇗M⇖ A+B"
  apply (simp add: def_lepoll_rel)
  apply (rule_tac x = "λx∈A ∪ B. if x∈A then Inl (x) else Inr (x)" in rexI)
   apply (rule_tac d = "%z. snd (z)" in lam_injective)
    apply force
   apply (simp add: Inl_def Inr_def)
proof -
  assume "M(A)" "M(B)"
  then
  show "M(λx∈A ∪ B. if x ∈ A then Inl(x) else Inr(x))"
    using transM[OF _ ‹M(A)›] transM[OF _ ‹M(B)›] if_then_Inj_replacement
    by (rule_tac lam_closed) auto
qed

lemma well_ord_Un_M:
  assumes "well_ord(X,R)" "well_ord(Y,S)"
    and types: "M(X)" "M(R)" "M(Y)" "M(S)"
  shows "∃T[M]. well_ord(X ∪ Y, T)"
  using assms
  by (erule_tac well_ord_radd [THEN [3] Un_lepoll_rel_sum [THEN lepoll_rel_well_ord]])
    (auto simp add: types)

lemma disj_Un_eqpoll_rel_sum: "M(A) ⟹ M(B) ⟹ A ∩ B = 0 ⟹ A ∪ B ≈⇗M⇖ A + B"
  apply (simp add: def_eqpoll_rel)
  apply (rule_tac x = "λa∈A ∪ B. if a ∈ A then Inl (a) else Inr (a)" in rexI)
   apply (rule_tac d = "%z. case (%x. x, %x. x, z)" in lam_bijective)
      apply auto
proof -
  assume "M(A)" "M(B)"
  then
  show "M(λx∈A ∪ B. if x ∈ A then Inl(x) else Inr(x))"
    using transM[OF _ ‹M(A)›] transM[OF _ ‹M(B)›] if_then_Inj_replacement
    by (rule_tac lam_closed) auto
qed

lemma eqpoll_rel_imp_Finite_rel_iff: "A ≈⇗M⇖ B ==> M(A) ⟹ M(B) ⟹ Finite_rel(M,A) ⟷ Finite_rel(M,B)"
  apply (unfold Finite_rel_def)
  apply (blast intro: eqpoll_rel_trans eqpoll_rel_sym)
  done

― ‹It seems reasonable to have the absoluteness of term‹Finite› here,
and deduce the rest of the results from this.

Perhaps modularize that proof to have absoluteness of injections and
bijections of finite sets (cf. @{thm lesspoll_rel_succ_imp_lepoll_rel}.›

lemma Finite_abs[simp]: assumes "M(A)" shows "Finite_rel(M,A) ⟷ Finite(A)"
  unfolding Finite_rel_def Finite_def
proof (simp, intro iffI)
  assume "∃n∈nat. A ≈⇗M⇖ n"
  then
  obtain n where "A ≈⇗M⇖ n" "n∈nat" by blast
  with assms
  show "∃n∈nat. A ≈ n"
    unfolding eqpoll_def using nat_into_M by (auto simp add:def_eqpoll_rel)
next
  fix n
  assume "∃n∈nat. A ≈ n"
  then
  obtain n where "A ≈ n" "n∈nat" by blast
  moreover from this
  obtain f where "f ∈ bij(A,n)" unfolding eqpoll_def by auto
  moreover
  note assms
  moreover from calculation
  have "converse(f) ∈ n→A"  using bij_is_fun by simp
  moreover from calculation
  have "M(converse(f))" using transM[of _ "n→A"] by simp
  moreover from calculation
  have "M(f)" using bij_is_fun
      fun_is_rel[of "f" A "λ_. n", THEN converse_converse]
      converse_closed[of "converse(f)"] by simp
  ultimately
  show "∃n∈nat. A ≈⇗M⇖ n"
    by (force dest:nat_into_M simp add:def_eqpoll_rel)
qed

(*
― ‹From the next result, the relative versions of
@{thm Finite_Fin_lemma} and @{thm Fin_lemma} should follow›
lemma nat_eqpoll_imp_eqpoll_rel:
  assumes "n ∈ nat" "A ≈ n" and types:"M(n)" "M(A)"
  shows "A ≈M n"
*)

lemma lepoll_rel_nat_imp_Finite_rel:
  assumes A: "A ≲⇗M⇖ n" and n: "n ∈ nat"
    and types: "M(A)" "M(n)"
  shows "Finite_rel(M,A)"
proof -
  have "A ≲⇗M⇖ n ⟹ Finite_rel(M,A)" using n
  proof (induct n)
    case 0
    hence "A = 0" by (rule lepoll_rel_0_is_0, simp_all add:types)
    thus ?case by simp
  next
    case (succ n)
    hence "A ≲⇗M⇖ n ∨ A ≈⇗M⇖ succ(n)" by (blast dest: lepoll_rel_succ_disj intro:types)
    thus ?case using succ by (auto simp add: Finite_rel_def types)
  qed
  thus ?thesis using A .
qed

lemma lesspoll_rel_nat_is_Finite_rel:
  "A ≺⇗M⇖ nat ⟹ M(A) ⟹ Finite_rel(M,A)"
  apply (unfold Finite_rel_def)
  apply (auto dest: ltD lesspoll_rel_cardinal_rel_lt
      lesspoll_rel_imp_eqpoll_rel [THEN eqpoll_rel_sym])
  done

lemma lepoll_rel_Finite_rel:
  assumes Y: "Y ≲⇗M⇖ X" and X: "Finite_rel(M,X)"
    and types:"M(Y)" "M(X)"
  shows "Finite_rel(M,Y)"
proof -
  obtain n where n: "n ∈ nat" "X ≈⇗M⇖ n" "M(n)" using X
    by (auto simp add: Finite_rel_def)
  have "Y ≲⇗M⇖ X"         by (rule Y)
  also have "... ≈⇗M⇖ n"  by (rule n)
  finally have "Y ≲⇗M⇖ n" by (simp_all add:types ‹M(n)›)
  thus ?thesis using n
    by (simp add: lepoll_rel_nat_imp_Finite_rel types ‹M(n)› del:Finite_abs)
qed

lemma succ_lepoll_rel_imp_not_empty: "succ(x) ≲⇗M⇖ y ==> M(x) ⟹ M(y) ⟹ y ≠ 0"
  by (fast dest!: lepoll_rel_0_is_0)

lemma eqpoll_rel_succ_imp_not_empty: "x ≈⇗M⇖ succ(n) ==> M(x) ⟹ M(n) ⟹ x ≠ 0"
  by (fast elim!: eqpoll_rel_sym [THEN eqpoll_rel_0_is_0, THEN succ_neq_0])

lemma Finite_subset_closed:
  assumes "Finite(B)" "B⊆A" "M(A)"
  shows "M(B)"
proof -
  from ‹Finite(B)› ‹B⊆A›
  show ?thesis
  proof(induct,simp)
    case (cons x D)
    with assms
    have "M(D)" "x∈A"
      unfolding cons_def by auto
    then
    show ?case using transM[OF _ ‹M(A)›] by simp
  qed
qed

lemma Finite_Pow_abs:
  assumes "Finite(A)" " M(A)"
  shows "Pow(A) = Pow_rel(M,A)"
  using Finite_subset_closed[OF subset_Finite] assms Pow_rel_char
  by auto

lemma Finite_Pow_rel:
  assumes "Finite(A)" "M(A)"
  shows "Finite(Pow_rel(M,A))"
  using Finite_Pow Finite_Pow_abs[symmetric] assms by simp

lemma Pow_rel_0 [simp]: "Pow_rel(M,0) = {0}"
  using Finite_Pow_abs[of 0] by simp

lemma eqpoll_rel_imp_Finite: "A ≈⇗M⇖ B ⟹ Finite(A) ⟹ M(A) ⟹ M(B) ⟹ Finite(B)"
proof -
  assume "A ≈⇗M⇖ B" "Finite(A)" "M(A)" "M(B)"
  then obtain f n g where "f∈bij(A,B)" "n∈nat" "g∈bij(A,n)"
    unfolding Finite_def eqpoll_def eqpoll_rel_def
    using bij_rel_char
    by auto
  then
  have "g O converse(f) ∈ bij(B,n)"
    using bij_converse_bij comp_bij by simp
  with ‹n∈_›
  show"Finite(B)"
    unfolding Finite_def eqpoll_def by auto
qed

lemma eqpoll_rel_imp_Finite_iff: "A ≈⇗M⇖ B ⟹ M(A) ⟹ M(B) ⟹ Finite(A) ⟷ Finite(B)"
  using eqpoll_rel_imp_Finite eqpoll_rel_sym by force

end ― ‹locale‹M_cardinals››

end
ead>

Theory CardinalArith_Relative

section‹Relative, Choice-less Cardinal Arithmetic›

theory CardinalArith_Relative
  imports
    Cardinal_Relative

begin


(* rvimage(?A, ?f, ?r) ≡ {z ∈ ?A × ?A . ∃x y. z = ⟨x, y⟩ ∧ ⟨?f ` x, ?f ` y⟩ ∈ ?r} *)
relativize functional "rvimage" "rvimage_rel" external
relationalize "rvimage_rel" "is_rvimage"

definition
  csquare_lam :: "i⇒i" where
  "csquare_lam(K) ≡ λ⟨x,y⟩∈K×K. ⟨x ∪ y, x, y⟩"

― ‹Can't do the next thing because split is a missing HOC›
(* relativize functional "csquare_lam" "csquare_lam_rel" *)
relativize_tm "<fst(x) ∪ snd(x), fst(x), snd(x)>" "is_csquare_lam_body"

definition
  is_csquare_lam :: "[i⇒o,i,i]⇒o" where
  "is_csquare_lam(M,K,l) ≡ ∃K2[M]. cartprod(M,K,K,K2) ∧
        is_lambda(M,K2,is_csquare_lam_body(M),l)"

definition jump_cardinal_body :: "[i⇒o,i] ⇒ i" where
  "jump_cardinal_body(M,X) ≡
    {z . r ∈ Pow⇗M⇖(X × X), M(z) ∧ M(r) ∧ well_ord(X, r) ∧ z = ordertype(X, r)} "

lemma (in M_cardinals) csquare_lam_closed[intro,simp]: "M(K) ⟹ M(csquare_lam(K))"
  using csquare_lam_replacement  unfolding csquare_lam_def
  by (rule lam_closed) (auto dest:transM)

locale M_pre_cardinal_arith = M_cardinals +
  assumes
    wfrec_pred_replacement:"M(A) ⟹ M(r) ⟹
      wfrec_replacement(M, λx f z. z = f `` Order.pred(A, x, r), r)"
begin

lemma ord_iso_separation: "M(A) ⟹ M(r) ⟹ M(s) ⟹
      separation(M, λf. ∀x∈A. ∀y∈A. ⟨x, y⟩ ∈ r ⟷ ⟨f ` x, f ` y⟩ ∈ s)"
  using
    lam_replacement_Pair[THEN[5] lam_replacement_hcomp2]
    lam_replacement_hcomp lam_replacement_fst  lam_replacement_snd
    separation_in lam_replacement_fst lam_replacement_apply2[THEN[5] lam_replacement_hcomp2]
    lam_replacement_identity  lam_replacement_constant
  by(rule_tac separation_ball,rule_tac separation_ball,simp_all,rule_tac separation_iff',simp_all)

end

locale M_cardinal_arith = M_pre_cardinal_arith +
  assumes
    ordertype_replacement :
    "M(X) ⟹ strong_replacement(M,λ x z . M(z) ∧ M(x) ∧ x∈Pow_rel(M,X×X) ∧ well_ord(X, x) ∧ z=ordertype(X,x))"
    and
    strong_replacement_jc_body :
    "strong_replacement(M,λ x z . M(z) ∧ M(x) ∧ z = jump_cardinal_body(M,x))"

lemmas (in M_cardinal_arith) surj_imp_inj_replacement =
  surj_imp_inj_replacement1 surj_imp_inj_replacement2 surj_imp_inj_replacement4
  lam_replacement_vimage_sing_fun[THEN lam_replacement_imp_strong_replacement]

relativize_tm "∃x' y' x y. z = ⟨⟨x', y'⟩, x, y⟩ ∧ (⟨x', x⟩ ∈ r ∨ x' = x ∧ ⟨y', y⟩ ∈ s)"
  "is_rmultP"

relativize functional "rmult" "rmult_rel" external
relationalize "rmult_rel" "is_rmult"

lemma (in M_trivial) rmultP_abs [absolut]: "⟦ M(r); M(s); M(z) ⟧ ⟹ is_rmultP(M,s,r,z) ⟷
    (∃x' y' x y. z = ⟨⟨x', y'⟩, x, y⟩ ∧ (⟨x', x⟩ ∈ r ∨ x' = x ∧ ⟨y', y⟩ ∈ s))"
  unfolding is_rmultP_def by (auto dest:transM)

definition
  is_csquare_rel :: "[i⇒o,i,i]⇒o"  where
  "is_csquare_rel(M,K,cs) ≡ ∃K2[M]. ∃la[M]. ∃memK[M].
      ∃rmKK[M]. ∃rmKK2[M].
        cartprod(M,K,K,K2) ∧ is_csquare_lam(M,K,la) ∧
        membership(M,K,memK) ∧ is_rmult(M,K,memK,K,memK,rmKK) ∧
        is_rmult(M,K,memK,K2,rmKK,rmKK2) ∧ is_rvimage(M,K2,la,rmKK2,cs)"

context M_basic
begin

lemma rvimage_abs[absolut]:
  assumes "M(A)" "M(f)" "M(r)" "M(z)"
  shows "is_rvimage(M,A,f,r,z) ⟷ z = rvimage(A,f,r)"
  using assms transM[OF _ ‹M(A)›]
  unfolding is_rvimage_def rvimage_def
  by auto

lemma rmult_abs [absolut]: "⟦ M(A); M(r); M(B); M(s); M(z) ⟧ ⟹
    is_rmult(M,A,r,B,s,z) ⟷ z=rmult(A,r,B,s)"
  using rmultP_abs transM[of _ "(A × B) × A × B"]
  unfolding is_rmultP_def is_rmult_def rmult_def
  by (auto del: iffI)

lemma csquare_lam_body_abs[absolut]: "M(x) ⟹ M(z) ⟹
  is_csquare_lam_body(M,x,z) ⟷ z = <fst(x) ∪ snd(x), fst(x), snd(x)>"
  unfolding is_csquare_lam_body_def by (simp add:absolut)

lemma csquare_lam_abs[absolut]: "M(K) ⟹ M(l) ⟹
  is_csquare_lam(M,K,l) ⟷ l = (λx∈K×K. ⟨fst(x) ∪ snd(x), fst(x), snd(x)⟩)"
  unfolding is_csquare_lam_def
  using lambda_abs2[of "K×K" "is_csquare_lam_body(M)"
      "λx. ⟨fst(x) ∪ snd(x), fst(x), snd(x)⟩"]
  unfolding Relation1_def by (simp add:absolut)

lemma csquare_lam_eq_lam:"csquare_lam(K) = (λz∈K×K. <fst(z) ∪ snd(z), fst(z), snd(z)>)"
proof -
  have "(λ⟨x,y⟩∈K × K. ⟨x ∪ y, x, y⟩)`z =
      (λz∈K×K. <fst(z) ∪ snd(z), fst(z), snd(z)>)`z" if "z∈K×K" for z
    using that by auto
  then
  show ?thesis
    unfolding csquare_lam_def
    by simp
qed

end ― ‹locale‹M_basic››

context M_pre_cardinal_arith
begin

lemma csquare_rel_closed[intro,simp]: "M(K) ⟹ M(csquare_rel(K))"
  using csquare_lam_replacement unfolding csquare_rel_def
  by (intro rvimage_closed lam_closed) (auto dest:transM)

(* Ugly proof ahead, please enhance *)
lemma csquare_rel_abs[absolut]: "⟦ M(K); M(cs)⟧ ⟹
     is_csquare_rel(M,K,cs) ⟷ cs = csquare_rel(K)"
  unfolding is_csquare_rel_def csquare_rel_def
  using csquare_lam_closed[unfolded csquare_lam_eq_lam]
  by (simp add:absolut csquare_lam_eq_lam[unfolded csquare_lam_def])

end ― ‹locale‹M_pre_cardinal_arith››

(*************   Discipline for csucc  ****************)
relativize functional "csucc" "csucc_rel" external
relationalize "csucc_rel" "is_csucc"
synthesize "is_csucc" from_definition assuming "nonempty"
arity_theorem for "is_csucc_fm"

abbreviation
  csucc_r :: "[i,i⇒o] ⇒ i"  (‹'(_+')⇗_⇖›) where
  "csucc_r(x,M) ≡ csucc_rel(M,x)"

abbreviation
  csucc_r_set :: "[i,i] ⇒ i"  (‹'(_+')⇗_⇖›) where
  "csucc_r_set(x,M) ≡ csucc_rel(##M,x)"

context M_Perm
begin

rel_closed for "csucc"
  using Least_closed'[of "λ L. M(L) ∧ Card⇗M⇖(L) ∧ K < L"]
  unfolding csucc_rel_def
  by simp

is_iff_rel for "csucc"
  using least_abs'[of "λ L. M(L) ∧ Card⇗M⇖(L) ∧ K < L" res]
    is_Card_iff
  unfolding is_csucc_def csucc_rel_def
  by (simp add:absolut)

end ― ‹locale‹M_Perm››

notation csucc_rel (‹csucc⇗_⇖'(_')›)

(***************  end Discipline  *********************)

context M_cardinals
begin

lemma Card_rel_Union [simp,intro,TC]:
  assumes A: "⋀x. x∈A ⟹ Card⇗M⇖(x)" and
    types:"M(A)"
  shows "Card⇗M⇖(⋃(A))"
proof (rule Card_relI)
  show "Ord(⋃A)" using A
    by (simp add: Card_rel_is_Ord types transM)
next
  fix j
  assume j: "j < ⋃A"
  moreover from this
  have "M(j)" unfolding lt_def by (auto simp add:types dest:transM)
  from j
  have "∃c∈A. j ∈ c ∧ Card⇗M⇖(c)" using A types
    unfolding lt_def
    by (simp)
  then
  obtain c where c: "c∈A" "j < c" "Card⇗M⇖(c)" "M(c)"
    using Card_rel_is_Ord types unfolding lt_def
    by (auto dest:transM)
  with ‹M(j)›
  have jls: "j ≺⇗M⇖ c"
    by (simp add: lt_Card_rel_imp_lesspoll_rel types)
  { assume eqp: "j ≈⇗M⇖ ⋃A"
    have  "c ≲⇗M⇖ ⋃A" using c
      by (blast intro: subset_imp_lepoll_rel types)
    also from types ‹M(j)›
    have "... ≈⇗M⇖ j"  by (rule_tac eqpoll_rel_sym [OF eqp]) (simp_all add:types)
    also have "... ≺⇗M⇖ c"  by (rule jls)
    finally have "c ≺⇗M⇖ c" by (simp_all add:‹M(c)› ‹M(j)› types)
    with ‹M(c)›
    have False
      by (auto dest:lesspoll_rel_irrefl)
  } thus "¬ j ≈⇗M⇖ ⋃A" by blast
qed (simp_all add:types)

(*
lemma Card_UN: "(!!x. x ∈ A ==> Card(K(x))) ==> Card(⋃x∈A. K(x))"
  by blast


lemma Card_OUN [simp,intro,TC]:
     "(!!x. x ∈ A ==> Card(K(x))) ==> Card(⋃x<A. K(x))"
  by (auto simp add: OUnion_def Card_0)
*)

lemma in_Card_imp_lesspoll: "[| Card⇗M⇖(K); b ∈ K; M(K); M(b) |] ==> b ≺⇗M⇖ K"
  apply (unfold lesspoll_rel_def)
  apply (simp add: Card_rel_iff_initial)
  apply (fast intro!: le_imp_lepoll_rel ltI leI)
  done


subsection‹Cardinal addition›

text‹Note (Paulson): Could omit proving the algebraic laws for cardinal addition and
multiplication.  On finite cardinals these operations coincide with
addition and multiplication of natural numbers; on infinite cardinals they
coincide with union (maximum).  Either way we get most laws for free.›

subsubsection‹Cardinal addition is commutative›

lemma sum_commute_eqpoll_rel: "M(A) ⟹ M(B) ⟹ A+B ≈⇗M⇖ B+A"
proof (simp add: def_eqpoll_rel, rule rexI)
  show "(λz∈A+B. case(Inr,Inl,z)) ∈ bij(A+B, B+A)"
    by (auto intro: lam_bijective [where d = "case(Inr,Inl)"])
  assume "M(A)" "M(B)"
  then
  show "M(λz∈A + B. case(Inr, Inl, z))"
    using case_replacement1
    by (rule_tac lam_closed) (auto dest:transM)
qed

lemma cadd_rel_commute: "M(i) ⟹ M(j) ⟹ i ⊕⇗M⇖ j = j ⊕⇗M⇖ i"
  apply (unfold cadd_rel_def)
  apply (auto intro: sum_commute_eqpoll_rel [THEN cardinal_rel_cong])
  done

subsubsection‹Cardinal addition is associative›

lemma sum_assoc_eqpoll_rel: "M(A) ⟹ M(B) ⟹ M(C) ⟹ (A+B)+C ≈⇗M⇖ A+(B+C)"
  apply (simp add: def_eqpoll_rel)
  apply (rule rexI)
   apply (rule sum_assoc_bij)
  using case_replacement2
  by (rule_tac lam_closed) (auto dest:transM)

text‹Unconditional version requires AC›
lemma well_ord_cadd_rel_assoc:
  assumes i: "well_ord(i,ri)" and j: "well_ord(j,rj)" and k: "well_ord(k,rk)"
    and
    types: "M(i)" "M(ri)" "M(j)" "M(rj)" "M(k)" "M(rk)"
  shows "(i ⊕⇗M⇖ j) ⊕⇗M⇖ k = i ⊕⇗M⇖ (j ⊕⇗M⇖ k)"
proof (simp add: assms cadd_rel_def, rule cardinal_rel_cong)
  from types
  have "|i + j|⇗M⇖ + k ≈⇗M⇖ (i + j) + k"
    by (auto intro!: sum_eqpoll_rel_cong well_ord_cardinal_rel_eqpoll_rel eqpoll_rel_refl well_ord_radd i j)
  also have "...  ≈⇗M⇖ i + (j + k)"
    by (rule sum_assoc_eqpoll_rel) (simp_all add:types)
  also
  have "...  ≈⇗M⇖ i + |j + k|⇗M⇖"
  proof (auto intro!: sum_eqpoll_rel_cong intro:eqpoll_rel_refl simp add:types)
    from types
    have "|j + k|⇗M⇖ ≈⇗M⇖ j + k"
      using well_ord_cardinal_rel_eqpoll_rel[OF well_ord_radd, OF j k]
      by (simp)
    with types
    show "j + k ≈⇗M⇖ |j + k|⇗M⇖"
      using eqpoll_rel_sym by simp
  qed
  finally show "|i + j|⇗M⇖ + k ≈⇗M⇖ i + |j + k|⇗M⇖" by (simp_all add:types)
qed (simp_all add:types)


subsubsection‹0 is the identity for addition›

lemma case_id_eq: "x∈sum(A,B) ⟹ case(λz . z, λz. z ,x) = snd(x)"
  unfolding case_def cond_def by (auto simp:Inl_def Inr_def)

lemma lam_case_id: "(λz∈0 + A. case(λx. x, λy. y, z)) = (λz∈0 + A . snd(z))"
  using case_id_eq by simp

lemma sum_0_eqpoll_rel: "M(A) ⟹ 0+A ≈⇗M⇖ A"
  apply (simp add:def_eqpoll_rel)
  apply (rule rexI)
   apply (rule bij_0_sum,subst lam_case_id)
  using lam_replacement_snd[unfolded lam_replacement_def]
  by (rule lam_closed)
    (auto simp add:case_def cond_def Inr_def dest:transM)

lemma cadd_rel_0 [simp]: "Card⇗M⇖(K) ⟹ M(K) ⟹ 0 ⊕⇗M⇖ K = K"
  apply (simp add: cadd_rel_def)
  apply (simp add: sum_0_eqpoll_rel [THEN cardinal_rel_cong] Card_rel_cardinal_rel_eq)
  done

subsubsection‹Addition by another cardinal›

lemma sum_lepoll_rel_self: "M(A) ⟹ M(B) ⟹ A ≲⇗M⇖ A+B"
proof (simp add: def_lepoll_rel, rule rexI)
  show "(λx∈A. Inl (x)) ∈ inj(A, A + B)"
    by (simp add: inj_def)
  assume "M(A)" "M(B)"
  then
  show "M(λx∈A. Inl(x))"
    using Inl_replacement1 transM[OF _ ‹M(A)›]
    by (rule_tac lam_closed) (auto simp add: Inl_def)
qed

(*Could probably weaken the premises to well_ord(K,r), or removing using AC*)

lemma cadd_rel_le_self:
  assumes K: "Card⇗M⇖(K)" and L: "Ord(L)" and
    types:"M(K)" "M(L)"
  shows "K ≤ (K ⊕⇗M⇖ L)"
proof (simp add:types cadd_rel_def)
  have "K ≤ |K|⇗M⇖"
    by (rule Card_rel_cardinal_rel_le [OF K]) (simp add:types)
  moreover have "|K|⇗M⇖ ≤ |K + L|⇗M⇖" using K L
    by (blast intro: well_ord_lepoll_rel_imp_cardinal_rel_le sum_lepoll_rel_self
        well_ord_radd well_ord_Memrel Card_rel_is_Ord types)
  ultimately show "K ≤ |K + L|⇗M⇖"
    by (blast intro: le_trans)
qed

subsubsection‹Monotonicity of addition›

lemma sum_lepoll_rel_mono:
  "[| A ≲⇗M⇖ C;  B ≲⇗M⇖ D; M(A); M(B); M(C); M(D) |] ==> A + B ≲⇗M⇖ C + D"
  apply (simp add: def_lepoll_rel)
  apply (elim rexE)
  apply (rule_tac x = "λz∈A+B. case (%w. Inl(f`w), %y. Inr(fa`y), z)" in rexI)
   apply (rule_tac d = "case (%w. Inl(converse(f) `w), %y. Inr(converse(fa) ` y))"
      in lam_injective)
    apply (typecheck add: inj_is_fun, auto)
  apply (rule_tac lam_closed, auto dest:transM intro:case_replacement4)
  done

lemma cadd_rel_le_mono:
  "[| K' ≤ K;  L' ≤ L;M(K');M(K);M(L');M(L) |] ==> (K' ⊕⇗M⇖ L') ≤ (K ⊕⇗M⇖ L)"
  apply (unfold cadd_rel_def)
  apply (safe dest!: le_subset_iff [THEN iffD1])
  apply (rule well_ord_lepoll_rel_imp_cardinal_rel_le)
      apply (blast intro: well_ord_radd well_ord_Memrel)
     apply (auto intro: sum_lepoll_rel_mono subset_imp_lepoll_rel)
  done

subsubsection‹Addition of finite cardinals is "ordinary" addition›

lemma sum_succ_eqpoll_rel: "M(A) ⟹ M(B) ⟹ succ(A)+B ≈⇗M⇖ succ(A+B)"
  apply (simp add:def_eqpoll_rel)
  apply (rule rexI)
   apply (rule_tac c = "%z. if z=Inl (A) then A+B else z"
      and d = "%z. if z=A+B then Inl (A) else z" in lam_bijective)
      apply simp_all
      apply (blast dest: sym [THEN eq_imp_not_mem] elim: mem_irrefl)+
  apply(rule_tac lam_closed, auto dest:transM intro:if_then_range_replacement2)
  done

(*Pulling the  succ(...)  outside the |...| requires m, n ∈ nat  *)
(*Unconditional version requires AC*)
lemma cadd_succ_lemma:
  assumes "Ord(m)" "Ord(n)" and
    types: "M(m)" "M(n)"
  shows "succ(m) ⊕⇗M⇖ n = |succ(m ⊕⇗M⇖ n)|⇗M⇖"
  using types
proof (simp add: cadd_rel_def)
  have [intro]: "m + n ≈⇗M⇖ |m + n|⇗M⇖" using assms
    by (blast intro: eqpoll_rel_sym well_ord_cardinal_rel_eqpoll_rel well_ord_radd well_ord_Memrel)

  have "|succ(m) + n|⇗M⇖ = |succ(m + n)|⇗M⇖"
    by (rule sum_succ_eqpoll_rel [THEN cardinal_rel_cong]) (simp_all add:types)
  also have "... = |succ(|m + n|⇗M⇖)|⇗M⇖"
    by (blast intro: succ_eqpoll_rel_cong cardinal_rel_cong types)
  finally show "|succ(m) + n|⇗M⇖ = |succ(|m + n|⇗M⇖)|⇗M⇖" .
qed

lemma nat_cadd_rel_eq_add:
  assumes m: "m ∈ nat" and [simp]: "n ∈ nat" shows"m ⊕⇗M⇖ n = m +ω n"
  using m
proof (induct m)
  case 0 thus ?case
    using transM[OF _ M_nat]
    by (auto simp add: nat_into_Card_rel)
next
  case (succ m) thus ?case
    using transM[OF _ M_nat]
    by (simp add: cadd_succ_lemma nat_into_Card_rel Card_rel_cardinal_rel_eq)
qed


subsection‹Cardinal multiplication›

subsubsection‹Cardinal multiplication is commutative›

lemma prod_commute_eqpoll_rel: "M(A) ⟹ M(B) ⟹ A*B ≈⇗M⇖ B*A"
  apply (simp add: def_eqpoll_rel)
  apply (rule rexI)
   apply (rule_tac c = "%<x,y>.<y,x>" and d = "%<x,y>.<y,x>" in lam_bijective,
      auto)
  apply(rule_tac lam_closed, auto intro:swap_replacement dest:transM)
  done

lemma cmult_rel_commute: "M(i) ⟹ M(j) ⟹ i ⊗⇗M⇖ j = j ⊗⇗M⇖ i"
  apply (unfold cmult_rel_def)
  apply (rule prod_commute_eqpoll_rel [THEN cardinal_rel_cong], simp_all)
  done

subsubsection‹Cardinal multiplication is associative›

lemma prod_assoc_eqpoll_rel: "M(A) ⟹ M(B) ⟹ M(C) ⟹ (A*B)*C ≈⇗M⇖ A*(B*C)"
  apply (simp add: def_eqpoll_rel)
  apply (rule rexI)
   apply (rule prod_assoc_bij)
  apply(rule_tac lam_closed, auto intro:assoc_replacement dest:transM)
  done


text‹Unconditional version requires AC›
lemma well_ord_cmult_rel_assoc:
  assumes i: "well_ord(i,ri)" and j: "well_ord(j,rj)" and k: "well_ord(k,rk)"
    and
    types: "M(i)" "M(ri)" "M(j)" "M(rj)" "M(k)" "M(rk)"
  shows "(i ⊗⇗M⇖ j) ⊗⇗M⇖ k = i ⊗⇗M⇖ (j ⊗⇗M⇖ k)"
proof (simp add: assms cmult_rel_def, rule cardinal_rel_cong)
  have "|i * j|⇗M⇖ * k ≈⇗M⇖ (i * j) * k"
    by (auto intro!: prod_eqpoll_rel_cong
        well_ord_cardinal_rel_eqpoll_rel eqpoll_rel_refl
        well_ord_rmult i j simp add:types)
  also have "...  ≈⇗M⇖ i * (j * k)"
    by (rule prod_assoc_eqpoll_rel, simp_all add:types)
  also have "...  ≈⇗M⇖ i * |j * k|⇗M⇖"
    by (blast intro: prod_eqpoll_rel_cong well_ord_cardinal_rel_eqpoll_rel
        eqpoll_rel_refl well_ord_rmult j k eqpoll_rel_sym types)
  finally show "|i * j|⇗M⇖ * k ≈⇗M⇖ i * |j * k|⇗M⇖" by (simp add:types)
qed (simp_all add:types)


subsubsection‹Cardinal multiplication distributes over addition›

lemma sum_prod_distrib_eqpoll_rel: "M(A) ⟹ M(B) ⟹ M(C) ⟹ (A+B)*C ≈⇗M⇖ (A*C)+(B*C)"
  apply (simp add: def_eqpoll_rel)
  apply (rule rexI)
   apply (rule sum_prod_distrib_bij)
  apply(rule_tac lam_closed, auto intro:case_replacement5 dest:transM)
  done


lemma well_ord_cadd_cmult_distrib:
  assumes i: "well_ord(i,ri)" and j: "well_ord(j,rj)" and k: "well_ord(k,rk)"
    and
    types: "M(i)" "M(ri)" "M(j)" "M(rj)" "M(k)" "M(rk)"
  shows "(i ⊕⇗M⇖ j) ⊗⇗M⇖ k = (i ⊗⇗M⇖ k) ⊕⇗M⇖ (j ⊗⇗M⇖ k)"
proof (simp add: assms cadd_rel_def cmult_rel_def, rule cardinal_rel_cong)
  have "|i + j|⇗M⇖ * k ≈⇗M⇖ (i + j) * k"
    by (blast intro: prod_eqpoll_rel_cong well_ord_cardinal_rel_eqpoll_rel
        eqpoll_rel_refl well_ord_radd i j types)
  also have "...  ≈⇗M⇖ i * k + j * k"
    by (rule sum_prod_distrib_eqpoll_rel) (simp_all add:types)
  also have "...  ≈⇗M⇖ |i * k|⇗M⇖ + |j * k|⇗M⇖"
    by (blast intro: sum_eqpoll_rel_cong well_ord_cardinal_rel_eqpoll_rel
        well_ord_rmult i j k eqpoll_rel_sym types)
  finally show "|i + j|⇗M⇖ * k ≈⇗M⇖ |i * k|⇗M⇖ + |j * k|⇗M⇖" by (simp add:types)
qed (simp_all add:types)


subsubsection‹Multiplication by 0 yields 0›

lemma prod_0_eqpoll_rel: "M(A) ⟹ 0*A ≈⇗M⇖ 0"
  apply (simp add: def_eqpoll_rel)
  apply (rule rexI)
   apply (rule lam_bijective, auto)
  done

lemma cmult_rel_0 [simp]: "M(i) ⟹ 0 ⊗⇗M⇖ i = 0"
  by (simp add: cmult_rel_def prod_0_eqpoll_rel [THEN cardinal_rel_cong])

subsubsection‹1 is the identity for multiplication›

lemma prod_singleton_eqpoll_rel: "M(x) ⟹ M(A) ⟹ {x}*A ≈⇗M⇖ A"
  apply (simp add: def_eqpoll_rel)
  apply (rule rexI)
   apply (rule singleton_prod_bij [THEN bij_converse_bij])
  apply (rule converse_closed)
  apply(rule_tac lam_closed, auto intro:prepend_replacement dest:transM)
  done

lemma cmult_rel_1 [simp]: "Card⇗M⇖(K) ⟹ M(K) ⟹ 1 ⊗⇗M⇖ K = K"
  apply (simp add: cmult_rel_def succ_def)
  apply (simp add: prod_singleton_eqpoll_rel[THEN cardinal_rel_cong] Card_rel_cardinal_rel_eq)
  done

subsection‹Some inequalities for multiplication›

lemma prod_square_lepoll_rel: "M(A) ⟹ A ≲⇗M⇖ A*A"
  apply (simp add:def_lepoll_rel inj_def)
  apply (rule_tac x = "λx∈A. <x,x>" in rexI, simp)
  apply(rule_tac lam_closed, auto intro:id_replacement dest:transM)
  done

(*Could probably weaken the premise to well_ord(K,r), or remove using AC*)
lemma cmult_rel_square_le: "Card⇗M⇖(K) ⟹ M(K) ⟹ K ≤ K ⊗⇗M⇖ K"
  apply (unfold cmult_rel_def)
  apply (rule le_trans)
   apply (rule_tac [2] well_ord_lepoll_rel_imp_cardinal_rel_le)
       apply (rule_tac [3] prod_square_lepoll_rel)
       apply (simp add: le_refl Card_rel_is_Ord Card_rel_cardinal_rel_eq)
      apply (blast intro: well_ord_rmult well_ord_Memrel Card_rel_is_Ord)
     apply simp_all
  done

subsubsection‹Multiplication by a non-zero cardinal›

lemma prod_lepoll_rel_self: "b ∈ B ⟹ M(b) ⟹ M(B) ⟹ M(A) ⟹ A ≲⇗M⇖ A*B"
  apply (simp add: def_lepoll_rel inj_def)
  apply (rule_tac x = "λx∈A. <x,b>" in rexI, simp)
  apply(rule_tac lam_closed, auto intro:pospend_replacement dest:transM)
  done

(*Could probably weaken the premises to well_ord(K,r), or removing using AC*)
lemma cmult_rel_le_self:
  "[| Card⇗M⇖(K);  Ord(L);  0<L; M(K);M(L) |] ==> K ≤ (K ⊗⇗M⇖ L)"
  apply (unfold cmult_rel_def)
  apply (rule le_trans [OF Card_rel_cardinal_rel_le well_ord_lepoll_rel_imp_cardinal_rel_le])
        apply assumption apply simp
      apply (blast intro: well_ord_rmult well_ord_Memrel Card_rel_is_Ord)
     apply (auto intro: prod_lepoll_rel_self ltD)
  done

subsubsection‹Monotonicity of multiplication›

lemma prod_lepoll_rel_mono:
  "[| A ≲⇗M⇖ C;  B ≲⇗M⇖ D; M(A); M(B); M(C); M(D)|] ==> A * B  ≲⇗M⇖  C * D"
  apply (simp add:def_lepoll_rel)
  apply (elim rexE)
  apply (rule_tac x = "lam <w,y>:A*B. <f`w, fa`y>" in rexI)
   apply (rule_tac d = "%<w,y>. <converse (f) `w, converse (fa) `y>"
      in lam_injective)
    apply (typecheck add: inj_is_fun, auto)
  apply(rule_tac lam_closed, auto intro:prod_fun_replacement dest:transM)
  done

lemma cmult_rel_le_mono:
  "[| K' ≤ K;  L' ≤ L;M(K');M(K);M(L');M(L) |] ==> (K' ⊗⇗M⇖ L') ≤ (K ⊗⇗M⇖ L)"
  apply (unfold cmult_rel_def)
  apply (safe dest!: le_subset_iff [THEN iffD1])
  apply (rule well_ord_lepoll_rel_imp_cardinal_rel_le)
      apply (blast intro: well_ord_rmult well_ord_Memrel)
     apply (auto intro: prod_lepoll_rel_mono subset_imp_lepoll_rel)
  done

subsection‹Multiplication of finite cardinals is "ordinary" multiplication›

lemma prod_succ_eqpoll_rel: "M(A) ⟹ M(B) ⟹ succ(A)*B ≈⇗M⇖ B + A*B"
  apply (simp add: def_eqpoll_rel)
  apply (rule rexI)
   apply (rule_tac c = "λp. if fst(p)=A then Inl (snd(p)) else Inr (p)"
      and d = "case (%y. <A,y>, %z. z)" in lam_bijective)
      apply safe
          apply (simp_all add: succI2 if_type mem_imp_not_eq)
  apply(rule_tac lam_closed, auto intro:Inl_replacement2 dest:transM)
  done

(*Unconditional version requires AC*)
lemma cmult_rel_succ_lemma:
  "[| Ord(m);  Ord(n) ; M(m); M(n) |] ==> succ(m) ⊗⇗M⇖ n = n ⊕⇗M⇖ (m ⊗⇗M⇖ n)"
  apply (simp add: cmult_rel_def cadd_rel_def)
  apply (rule prod_succ_eqpoll_rel [THEN cardinal_rel_cong, THEN trans], simp_all)
  apply (rule cardinal_rel_cong [symmetric], simp_all)
  apply (rule sum_eqpoll_rel_cong [OF eqpoll_rel_refl well_ord_cardinal_rel_eqpoll_rel], assumption)
        apply (blast intro: well_ord_rmult well_ord_Memrel)
       apply simp_all
  done

lemma nat_cmult_rel_eq_mult: "[| m ∈ nat;  n ∈ nat |] ==> m ⊗⇗M⇖ n = m#*n"
  using transM[OF _ M_nat]
  apply (induct_tac m)
   apply (simp_all add: cmult_rel_succ_lemma nat_cadd_rel_eq_add)
  done

lemma cmult_rel_2: "Card⇗M⇖(n) ⟹ M(n) ⟹ 2 ⊗⇗M⇖ n = n ⊕⇗M⇖ n"
  by (simp add: cmult_rel_succ_lemma Card_rel_is_Ord cadd_rel_commute [of _ 0])

lemma sum_lepoll_rel_prod:
  assumes C: "2 ≲⇗M⇖ C" and
    types:"M(C)" "M(B)"
  shows "B+B ≲⇗M⇖ C*B"
proof -
  have "B+B ≲⇗M⇖ 2*B"
    by (simp add: sum_eq_2_times types)
  also have "... ≲⇗M⇖ C*B"
    by (blast intro: prod_lepoll_rel_mono lepoll_rel_refl C types)
  finally show "B+B ≲⇗M⇖ C*B" by (simp_all add:types)
qed

lemma lepoll_imp_sum_lepoll_prod: "[| A ≲⇗M⇖ B; 2 ≲⇗M⇖ A; M(A) ;M(B) |] ==> A+B ≲⇗M⇖ A*B"
  by (blast intro: sum_lepoll_rel_mono sum_lepoll_rel_prod lepoll_rel_trans lepoll_rel_refl)

end ― ‹locale‹M_cardinals››

subsection‹Infinite Cardinals are Limit Ordinals›

(*This proof is modelled upon one assuming nat<=A, with injection
  λz∈cons(u,A). if z=u then 0 else if z ∈ nat then succ(z) else z
  and inverse %y. if y ∈ nat then nat_case(u, %z. z, y) else y.  \
  If f ∈ inj(nat,A) then range(f) behaves like the natural numbers.*)


context M_pre_cardinal_arith
begin

lemma nat_cons_lepoll_rel: "nat ≲⇗M⇖ A ⟹ M(A) ⟹ M(u) ==> cons(u,A) ≲⇗M⇖ A"
  apply (simp add: def_lepoll_rel)
  apply (erule rexE)
  apply (rule_tac x =
      "λz∈cons (u,A).
             if z=u then f`0
             else if z ∈ range (f) then f`succ (converse (f) `z) else z"
      in rexI)
   apply (rule_tac d =
      "%y. if y ∈ range(f) then nat_case (u, %z. f`z, converse(f) `y)
                              else y"
      in lam_injective)
    apply (fast intro!: if_type apply_type intro: inj_is_fun inj_converse_fun)
   apply (simp add: inj_is_fun [THEN apply_rangeI]
      inj_converse_fun [THEN apply_rangeI]
      inj_converse_fun [THEN apply_funtype])
proof -
  fix f
  assume "M(A)" "M(f)" "M(u)"
  then
  show "M(λz∈cons(u, A). if z = u then f ` 0 else if z ∈ range(f) then f ` succ(converse(f) ` z) else z)"
    using if_then_range_replacement transM[OF _ ‹M(A)›]
    by (rule_tac lam_closed, auto)
qed

lemma nat_cons_eqpoll_rel: "nat ≲⇗M⇖ A ==> M(A) ⟹ M(u) ⟹ cons(u,A) ≈⇗M⇖ A"
  apply (erule nat_cons_lepoll_rel [THEN eqpoll_relI], assumption+)
    apply (rule subset_consI [THEN subset_imp_lepoll_rel], simp_all)
  done

lemma nat_succ_eqpoll_rel: "nat ⊆ A ==> M(A) ⟹ succ(A) ≈⇗M⇖ A"
  apply (unfold succ_def)
  apply (erule subset_imp_lepoll_rel [THEN nat_cons_eqpoll_rel], simp_all)
  done

lemma InfCard_rel_nat: "InfCard⇗M⇖(nat)"
  apply (simp add: InfCard_rel_def)
  apply (blast intro: Card_rel_nat Card_rel_is_Ord)
  done

lemma InfCard_rel_is_Card_rel: "M(K) ⟹ InfCard⇗M⇖(K) ⟹ Card⇗M⇖(K)"
  apply (simp add: InfCard_rel_def)
  done

lemma InfCard_rel_Un:
  "[| InfCard⇗M⇖(K);  Card⇗M⇖(L); M(K); M(L) |] ==> InfCard⇗M⇖(K ∪ L)"
  apply (simp add: InfCard_rel_def)
  apply (simp add: Card_rel_Un Un_upper1_le [THEN [2] le_trans]  Card_rel_is_Ord)
  done

lemma InfCard_rel_is_Limit: "InfCard⇗M⇖(K) ==> M(K) ⟹ Limit(K)"
  apply (simp add: InfCard_rel_def)
  apply (erule conjE)
  apply (frule Card_rel_is_Ord, assumption)
  apply (rule ltI [THEN non_succ_LimitI])
    apply (erule le_imp_subset [THEN subsetD])
    apply (safe dest!: Limit_nat [THEN Limit_le_succD])
  apply (unfold Card_rel_def)
  apply (drule trans)
   apply (erule le_imp_subset [THEN nat_succ_eqpoll_rel, THEN cardinal_rel_cong], simp_all)
  apply (erule Ord_cardinal_rel_le [THEN lt_trans2, THEN lt_irrefl], assumption)
  apply (rule le_eqI) prefer 2
   apply (rule Ord_cardinal_rel, assumption+)
  done

end ― ‹locale‹M_pre_cardinal_arith››

(*** An infinite cardinal equals its square (Kunen, Thm 10.12, page 29) ***)


lemma (in M_ordertype) ordertype_abs[absolut]:
  assumes "wellordered(M,A,r)" "M(A)" "M(r)" "M(i)"
  shows "otype(M,A,r,i) ⟷ i = ordertype(A,r)"
    ― ‹Awful proof, it essentially repeats the same argument twice›
proof (intro iffI)
  note assms
  moreover
  assume "otype(M, A, r, i)"
  moreover from calculation
  obtain f j where "M(f)"  "M(j)"  "Ord(j)" "f ∈ ⟨A, r⟩ ≅ ⟨j, Memrel(j)⟩"
    using ordertype_exists[of A r] by auto
  moreover from calculation
  have "∃f[M]. f ∈ ⟨A, r⟩ ≅ ⟨j, Memrel(j)⟩" by auto
  moreover
  have "∃f[M]. f ∈ ⟨A, r⟩ ≅ ⟨i, Memrel(i)⟩"
  proof -
    note calculation
    moreover from this
    obtain h where "omap(M, A, r, h)" "M(h)"
      using omap_exists by auto
    moreover from calculation
    have "h ∈ ⟨A, r⟩ ≅ ⟨i, Memrel(i)⟩"
      using omap_ord_iso obase_equals by simp
    moreover from calculation
    have "h O converse(f) ∈ ⟨j, Memrel(j)⟩ ≅ ⟨i, Memrel(i)⟩"
      using ord_iso_sym ord_iso_trans by blast
    moreover from calculation
    have "i=j"
      using Ord_iso_implies_eq[of j i "h O converse(f)"]
        Ord_otype[OF _ well_ord_is_trans_on] by simp
    ultimately
    show ?thesis by simp
  qed
  ultimately
  show "i = ordertype(A, r)"
    by (force intro:ordertypes_are_absolute[of A r _ i]
        simp add:Ord_otype[OF _ well_ord_is_trans_on])
next
  note assms
  moreover
  assume "i = ordertype(A, r)"
  moreover from calculation
  obtain h where "omap(M, A, r, h)" "M(h)"
    using omap_exists by auto
  moreover from calculation
  obtain j where "otype(M,A,r,j)" "M(j)"
    using otype_exists by auto
  moreover from calculation
  have "h ∈ ⟨A, r⟩ ≅ ⟨j, Memrel(j)⟩"
    using omap_ord_iso_otype by simp
  moreover from calculation
  obtain f where "f ∈ ⟨A, r⟩ ≅ ⟨i, Memrel(i)⟩"
    using ordertype_ord_iso by auto
  moreover
  have "j=i"
  proof -
    note calculation
    moreover from this
    have "h O converse(f) ∈ ⟨i, Memrel(i)⟩ ≅ ⟨j, Memrel(j)⟩"
      using ord_iso_sym ord_iso_trans by blast
    moreover from calculation
    have "Ord(i)" using Ord_ordertype by simp
    ultimately
    show "j=i"
      using Ord_iso_implies_eq[of i j "h O converse(f)"]
        Ord_otype[OF _ well_ord_is_trans_on] by simp
  qed
  ultimately
  show "otype(M, A, r, i)" by simp
qed

lemma (in M_ordertype) ordertype_closed[intro,simp]: "⟦ wellordered(M,A,r);M(A);M(r)⟧ ⟹ M(ordertype(A,r))"
  using ordertype_exists ordertypes_are_absolute by blast

(*
definition
  jump_cardinal :: "i=>i"  where
    ― ‹This definition is more complex than Kunen's but it more easily proved to
        be a cardinal›
    "jump_cardinal(K) ==
         ⋃X∈Pow(K). {z. r ∈ Pow(K*K), well_ord(X,r) & z = ordertype(X,r)}"
*)

relationalize "transitive_rel" "is_transitive" external
synthesize "is_transitive" from_definition assuming "nonempty"
arity_theorem for "is_transitive_fm"

lemma (in M_trivial) is_transitive_iff_transitive_rel:
  "M(A)⟹ M(r) ⟹ transitive_rel(M, A, r) ⟷ is_transitive(M,A, r)"
  unfolding transitive_rel_def is_transitive_def by simp

relationalize "linear_rel" "is_linear" external
synthesize "is_linear" from_definition assuming "nonempty"
arity_theorem for "is_linear_fm"

lemma (in M_trivial) is_linear_iff_linear_rel:
  "M(A)⟹ M(r) ⟹ is_linear(M,A, r) ⟷ linear_rel(M, A, r)"
  unfolding linear_rel_def is_linear_def by simp

relationalize "wellfounded_on" "is_wellfounded_on" external
synthesize "is_wellfounded_on" from_definition assuming "nonempty"
arity_theorem for "is_wellfounded_on_fm"

lemma (in M_trivial) is_wellfounded_on_iff_wellfounded_on:
  "M(A)⟹ M(r) ⟹ is_wellfounded_on(M,A, r) ⟷ wellfounded_on(M, A, r)"
  unfolding wellfounded_on_def is_wellfounded_on_def by simp

definition
  is_well_ord :: "[i=>o,i,i]=>o" where
  ― ‹linear and wellfounded on ‹A››
  "is_well_ord(M,A,r) ==
        is_transitive(M,A,r) ∧ is_linear(M,A,r) ∧ is_wellfounded_on(M,A,r)"

lemma (in M_trivial) is_well_ord_iff_wellordered:
  "M(A)⟹ M(r) ⟹  is_well_ord(M,A, r) ⟷ wellordered(M, A, r)"
  using is_wellfounded_on_iff_wellfounded_on is_linear_iff_linear_rel
    is_transitive_iff_transitive_rel
  unfolding wellordered_def is_well_ord_def by simp

reldb_add relational "well_ord" "is_well_ord"
reldb_add functional "well_ord" "well_ord"
synthesize "is_well_ord" from_definition assuming "nonempty"
arity_theorem for "is_well_ord_fm"

― ‹One keyword (functional or relational) means going
    from an absolute term to that kind of term›
reldb_add relational "Order.pred" "pred_set"

― ‹The following form (twice the same argument) is only correct
    when an "\_abs" theorem is available›
reldb_add functional "Order.pred" "Order.pred"

(*
― ‹Two keywords denote origin and destination, respectively›
reldb_add functional relational "Ord" "ordinal"
*)

relativize functional "ord_iso" "ord_iso_rel" external
  ― ‹The following corresponds to "relativize functional relational"›
relationalize "ord_iso_rel" "is_ord_iso"

context M_pre_cardinal_arith
begin

is_iff_rel for "ord_iso"
  using bij_rel_iff
  unfolding is_ord_iso_def ord_iso_rel_def
  by simp

rel_closed for "ord_iso"
  using ord_iso_separation unfolding ord_iso_rel_def
  by simp

end ― ‹locale‹M_pre_cardinal_arith››

synthesize "is_ord_iso" from_definition assuming "nonempty"

lemma is_lambda_iff_sats[iff_sats]:
  assumes is_F_iff_sats:
    "!!a0 a1 a2.
        [|a0∈Aa; a1∈Aa; a2∈Aa|]
        ==> is_F(a1, a0) ⟷ sats(Aa, is_F_fm, Cons(a0,Cons(a1,Cons(a2,env))))"
  shows
    "nth(A, env) = Ab ⟹
    nth(r, env) = ra ⟹
    A ∈ nat ⟹
    r ∈ nat ⟹
    env ∈ list(Aa) ⟹
    is_lambda(##Aa, Ab, is_F, ra) ⟷ Aa, env ⊨ lambda_fm(is_F_fm,A, r)"
  using sats_lambda_fm[OF assms, of A r] by simp

― ‹same as @{thm sats_is_wfrec_fm}, but changing length assumptions to
    term‹0› being in the model›
lemma sats_is_wfrec_fm':
  assumes MH_iff_sats:
    "!!a0 a1 a2 a3 a4.
        [|a0∈A; a1∈A; a2∈A; a3∈A; a4∈A|]
        ==> MH(a2, a1, a0) ⟷ sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,Cons(a4,env))))))"
  shows
    "[|x ∈ nat; y ∈ nat; z ∈ nat; env ∈ list(A); 0 ∈ A|]
       ==> sats(A, is_wfrec_fm(p,x,y,z), env) ⟷
           is_wfrec(##A, MH, nth(x,env), nth(y,env), nth(z,env))"
  using MH_iff_sats [THEN iff_sym] nth_closed sats_is_recfun_fm
  by (simp add: is_wfrec_fm_def is_wfrec_def) blast

lemma is_wfrec_iff_sats'[iff_sats]:
  assumes MH_iff_sats:
    "!!a0 a1 a2 a3 a4.
        [|a0∈Aa; a1∈Aa; a2∈Aa; a3∈Aa; a4∈Aa|]
        ==> MH(a2, a1, a0) ⟷ sats(Aa, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,Cons(a4,env))))))"
    "nth(x, env) = xx" "nth(y, env) = yy" "nth(z, env) = zz"
    "x ∈ nat" "y ∈ nat" "z ∈ nat" "env ∈ list(Aa)" "0 ∈ Aa"
  shows
    "is_wfrec(##Aa, MH, xx, yy, zz) ⟷ Aa, env ⊨ is_wfrec_fm(p,x,y,z)"
  using assms(2-4) sats_is_wfrec_fm'[OF assms(1,5-9)] by simp

lemma is_wfrec_on_iff_sats[iff_sats]:
  assumes MH_iff_sats:
    "!!a0 a1 a2 a3 a4.
        [|a0∈Aa; a1∈Aa; a2∈Aa; a3∈Aa; a4∈Aa|]
        ==> MH(a2, a1, a0) ⟷ sats(Aa, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,Cons(a4,env))))))"
  shows
    "nth(x, env) = xx ⟹
    nth(y, env) = yy ⟹
    nth(z, env) = zz ⟹
    x ∈ nat ⟹
    y ∈ nat ⟹
    z ∈ nat ⟹
    env ∈ list(Aa) ⟹
    0 ∈ Aa ⟹ is_wfrec_on(##Aa, MH, aa,xx, yy, zz) ⟷ Aa, env ⊨ is_wfrec_fm(p,x,y,z)"
  using assms sats_is_wfrec_fm'[OF assms] unfolding is_wfrec_on_def by simp

lemma trans_on_iff_trans: "trans[A](r) ⟷ trans(r ∩ A×A)"
  unfolding trans_on_def trans_def by auto

lemma trans_on_subset: "trans[A](r) ⟹ B ⊆ A ⟹ trans[B](r)"
  unfolding trans_on_def
  by auto

lemma relation_Int: "relation(r ∩ B×B)"
  unfolding relation_def
  by auto

text‹Discipline for term‹ordermap››
relativize functional "ordermap" "ordermap_rel" external
relationalize "ordermap_rel" "is_ordermap"

context M_pre_cardinal_arith
begin

lemma wfrec_on_pred_eq:
  assumes "r ∈ Pow(A×A)" "M(A)" "M(r)"
  shows "wfrec[A](r, x, λx f. f `` Order.pred(A, x, r)) = wfrec(r, x, λx f. f `` Order.pred(A, x, r))"
proof -
  from ‹r ∈ Pow(A×A)›
  have "r ∩ A×A = r" by auto
  moreover from this
  show ?thesis
    unfolding wfrec_on_def by simp
qed

lemma wfrec_on_pred_closed:
  assumes "wf[A](r)" "trans[A](r)" "r ∈ Pow(A×A)" "M(A)" "M(r)" "x ∈ A"
  shows "M(wfrec(r, x, λx f. f `` Order.pred(A, x, r)))"
proof -
  from assms
  have "wfrec[A](r, x, λx f. f `` Order.pred(A, x, r)) = wfrec(r, x, λx f. f `` Order.pred(A, x, r))"
    using wfrec_on_pred_eq by simp
  moreover from assms
  have "M(wfrec(r, x, λx f. f `` Order.pred(A, x, r)))"
    using wfrec_pred_replacement wf_on_imp_wf trans_on_imp_trans subset_Sigma_imp_relation
    by (rule_tac MH="λx f b. ∃a[M]. image(M, f, a, b) ∧ pred_set(M, A, x, r, a)" in trans_wfrec_closed)
      (auto dest:transM simp:relation2_def)
  ultimately
  show ?thesis by simp
qed

lemma wfrec_on_pred_closed':
  assumes "wf[A](r)" "trans[A](r)" "r ∈ Pow(A×A)" "M(A)" "M(r)" "x ∈ A"
  shows "M(wfrec[A](r, x, λx f. f `` Order.pred(A, x, r)))"
  using assms wfrec_on_pred_closed wfrec_on_pred_eq by simp


lemma ordermap_rel_closed':
  assumes "wf[A](r)" "trans[A](r)" "r ∈ Pow(A×A)" "M(A)" "M(r)"
  shows "M(ordermap_rel(M, A, r))"
proof -
  from assms
  have "r ∩ A×A = r" by auto
  with assms have "wf(r)" "trans(r)" "relation(r)"
    unfolding wf_on_def using trans_on_iff_trans relation_def by auto
  then
  have 1:"⋀ x z . M(x) ⟹ M(z) ⟹
    (∃y[M]. pair(M, x, y, z) ∧ is_wfrec(M, λx f z. z = f `` Order.pred(A, x, r), r, x, y))
      ⟷
    z = <x,wfrec(r,x,λx f. f `` Order.pred(A, x, r))>"
    using trans_wfrec_abs[of r,where
        H="λx f. f `` Order.pred(A, x, r)" and
        MH="λx f z . z= f `` Order.pred(A, x, r)",simplified] assms
      wfrec_pred_replacement unfolding relation2_def
    by auto
  then
  have "strong_replacement(M,λx z. z = <x,wfrec(r,x,λx f. f `` Order.pred(A, x, r))>)"
    using strong_replacement_cong[of M,OF 1,THEN iffD1,OF _ _
        wfrec_pred_replacement[unfolded wfrec_replacement_def]] assms by simp
  then show ?thesis
    using Pow_iff assms
    unfolding ordermap_rel_def
    apply(subst lam_cong[OF refl wfrec_on_pred_eq],simp_all)
    using wfrec_on_pred_closed lam_closed
    by simp
qed

lemma ordermap_rel_closed[intro,simp]:
  assumes "wf[A](r)" "trans[A](r)" "r ∈ Pow(A×A)"
  shows "M(A) ⟹ M(r) ⟹ M(ordermap_rel(M, A, r))"
  using ordermap_rel_closed' assms by simp

lemma is_ordermap_iff:
  assumes "r ∈ Pow(A×A)" "wf[A](r)" "trans[A](r)"
    "M(A)" "M(r)" "M(res)"
  shows "is_ordermap(M, A, r, res) ⟷ res = ordermap_rel(M, A, r)"
proof -
  from ‹r ∈ Pow(A×A)›
  have "r ∩ A×A = r" by auto
  with assms have 1:"wf(r)" "trans(r)" "relation(r)"
    unfolding wf_on_def using trans_on_iff_trans relation_def by auto
  from assms
  have "r ∩ A×A = r" "r ⊆ A×A" "<x,y> ∈ r ⟹ x∈A ∧ y∈A" for x y by auto
  then
  show ?thesis
    using ordermap_rel_closed[of r A] assms wfrec_on_pred_closed wfrec_pred_replacement 1
    unfolding is_ordermap_def ordermap_rel_def
    apply (rule_tac lambda_abs2)
       apply (simp_all add:Relation1_def)
     apply clarify
     apply (rule trans_wfrec_on_abs)
               apply (auto dest:transM simp add: relation_Int relation2_def)
    by(rule_tac wfrec_on_pred_closed'[of A r],auto)
qed

end ― ‹locale‹M_pre_cardinal_arith››

synthesize "is_ordermap" from_definition assuming "nonempty"

text‹Discipline for term‹ordertype››
relativize functional "ordertype" "ordertype_rel" external
relationalize "ordertype_rel" "is_ordertype"

context M_pre_cardinal_arith
begin

lemma is_ordertype_iff:
  assumes "r ∈ Pow(A×A)" "wf[A](r)" "trans[A](r)"
  shows "M(A) ⟹ M(r) ⟹ M(res) ⟹ is_ordertype(M, A, r, res) ⟷ res = ordertype_rel(M, A, r)"
  using assms is_ordermap_iff[of r A] trans_on_iff_trans
    ordermap_rel_closed[of A r]
  unfolding is_ordertype_def ordertype_rel_def wf_on_def by simp

lemma is_ordertype_iff':
  assumes "r ∈ Pow_rel(M,A×A)" "well_ord(A,r)"
  shows "M(A) ⟹ M(r) ⟹ M(res) ⟹ is_ordertype(M, A, r, res) ⟷ res = ordertype_rel(M, A, r)"
  using assms is_ordertype_iff Pow_rel_char
  unfolding well_ord_def part_ord_def tot_ord_def by simp

lemma is_ordertype_iff'':
  assumes "well_ord(A,r)" "r⊆A×A"
  shows "M(A) ⟹ M(r) ⟹ M(res) ⟹ is_ordertype(M, A, r, res) ⟷ res = ordertype_rel(M, A, r)"
  using assms is_ordertype_iff
  unfolding well_ord_def part_ord_def tot_ord_def by simp

end ― ‹locale‹M_pre_cardinal_arith››

synthesize "is_ordertype" from_definition assuming "nonempty"

― ‹NOTE: not quite the same as term‹jump_cardinal›,
    note term‹Pow(X*X)›.›
definition
  jump_cardinal' :: "i⇒i"  where
  "jump_cardinal'(K) ≡
         ⋃X∈Pow(K). {z. r ∈ Pow(X*X), well_ord(X,r) & z = ordertype(X,r)}"

relativize functional "jump_cardinal'" "jump_cardinal'_rel" external
relationalize "jump_cardinal'_rel" "is_jump_cardinal'"
synthesize "is_jump_cardinal'" from_definition assuming "nonempty"
arity_theorem for "is_jump_cardinal'_fm"
definition jump_cardinal_body' where
  "jump_cardinal_body'(X) ≡ {z . r ∈ Pow(X × X),  well_ord(X, r) ∧ z = ordertype(X, r)}"

relativize functional "jump_cardinal_body'" "jump_cardinal_body'_rel" external
relationalize "jump_cardinal_body'_rel" "is_jump_cardinal_body'"
synthesize "is_jump_cardinal_body'" from_definition assuming "nonempty"
arity_theorem for "is_jump_cardinal_body'_fm"

context M_pre_cardinal_arith
begin

lemma ordertype_rel_closed':
  assumes "wf[A](r)" "trans[A](r)" "r ∈ Pow(A×A)" "M(r)" "M(A)"
  shows "M(ordertype_rel(M,A,r))"
  unfolding ordertype_rel_def
  using ordermap_rel_closed image_closed assms by simp

lemma ordertype_rel_closed[intro,simp]:
  assumes "well_ord(A,r)" "r ∈ Pow_rel(M,A×A)" "M(A)"
  shows "M(ordertype_rel(M,A,r))"
  using assms Pow_rel_char ordertype_rel_closed'
  unfolding well_ord_def tot_ord_def part_ord_def
  by simp

lemma ordertype_rel_abs:
  assumes "wellordered(M,X,r)" "M(X)" "M(r)"
  shows "ordertype_rel(M,X,r) = ordertype(X,r)"
  using assms ordertypes_are_absolute[of X r]
  unfolding ordertype_def ordertype_rel_def ordermap_rel_def ordermap_def
  by simp

lemma univalent_aux1: "M(X) ⟹ univalent(M,Pow_rel(M,X×X),
  λr z. M(z) ∧ M(r) ∧ r∈Pow_rel(M,X×X) ∧ is_well_ord(M, X, r) ∧ is_ordertype(M, X, r, z))"
  using is_well_ord_iff_wellordered
    is_ordertype_iff[of _ X]
    trans_on_subset[OF well_ord_is_trans_on]
    well_ord_is_wf[THEN wf_on_subset_A] mem_Pow_rel_abs
  unfolding univalent_def
  by (simp)

lemma jump_cardinal_body_eq :
  "M(X) ⟹ jump_cardinal_body(M,X) = jump_cardinal_body'_rel(M,X)"
  unfolding jump_cardinal_body_def jump_cardinal_body'_rel_def
  using ordertype_rel_abs
  by auto

end ― ‹locale‹M_pre_cardinal_arith››

context M_cardinal_arith
begin
lemma jump_cardinal_closed_aux1:
  assumes "M(X)"
  shows
    "M(jump_cardinal_body(M,X))"
  unfolding jump_cardinal_body_def
  using ‹M(X)› ordertype_rel_abs
    ordertype_replacement[OF ‹M(X)›] univalent_aux1[OF ‹M(X)›]
    strong_replacement_closed[where A="Pow⇗M⇖(X × X)" and
      P="λ r z . M(z) ∧ M(r) ∧  r ∈ Pow⇗M⇖(X × X) ∧ well_ord(X, r) ∧ z = ordertype(X, r)"]
  by auto

lemma univalent_jc_body: "M(X) ⟹ univalent(M,X,λ x z . M(z) ∧ M(x) ∧ z = jump_cardinal_body(M,x))"
  using transM[of _ X]  jump_cardinal_closed_aux1 by auto

lemma jump_cardinal_body_closed:
  assumes "M(K)"
  shows "M({a . X ∈ Pow⇗M⇖(K), M(a) ∧ M(X) ∧ a = jump_cardinal_body(M,X)})"
  using assms univalent_jc_body jump_cardinal_closed_aux1 strong_replacement_jc_body
  by simp

rel_closed for "jump_cardinal'"
  using jump_cardinal_body_closed ordertype_rel_abs
  unfolding jump_cardinal_body_def jump_cardinal'_rel_def
  by simp

is_iff_rel for "jump_cardinal'"
proof -
  assume types: "M(K)" "M(res)"
  have "is_Replace(M, Pow_rel(M,X×X), λr z. M(z) ∧ M(r) ∧ is_well_ord(M, X, r) ∧ is_ordertype(M, X, r, z),
   a) ⟷ a = {z . r ∈ Pow_rel(M,X×X), M(z) ∧ M(r) ∧ is_well_ord(M,X,r) ∧ is_ordertype(M, X, r, z)}"
    if "M(X)" "M(a)" for X a
    using that univalent_aux1
    by (rule_tac Replace_abs) (simp_all)
  then
  have "is_Replace(M, Pow_rel(M,X×X), λr z. M(z) ∧ M(r) ∧ is_well_ord(M, X, r) ∧ is_ordertype(M, X, r, z),
   a) ⟷ a = {z . r ∈ Pow_rel(M,X×X), M(z) ∧ M(r) ∧ well_ord(X, r) ∧ z = ordertype_rel(M, X, r)}"
    if "M(X)" "M(a)" for X a
    using that univalent_aux1 is_ordertype_iff' is_well_ord_iff_wellordered well_ord_abs by auto
  moreover
  have "is_Replace(M, d, λX a. M(a) ∧ M(X) ∧
      a = {z . r ∈ Pow⇗M⇖(X × X), M(z) ∧ M(r) ∧ well_ord(X, r) ∧ z = ordertype(X, r)}, e)
    ⟷
    e ={a . X ∈ d, M(a) ∧ M(X) ∧ a = jump_cardinal_body(M,X)}"
    if "M(d)" "M(e)" for d e
    using jump_cardinal_closed_aux1 that
    unfolding jump_cardinal_body_def
    by (rule_tac Replace_abs) simp_all
  ultimately
  show ?thesis
    using Pow_rel_iff jump_cardinal_body_closed[of K] ordertype_rel_abs
    unfolding is_jump_cardinal'_def jump_cardinal'_rel_def jump_cardinal_body_def
    by (simp add: types)
qed

end

context M_cardinal_arith
begin

lemma (in M_ordertype) ordermap_closed[intro,simp]:
  assumes "wellordered(M,A,r)" and types:"M(A)" "M(r)"
  shows "M(ordermap(A,r))"
proof -
  note assms
  moreover from this
  obtain i f where "Ord(i)" "f ∈ ord_iso(A, r, i, Memrel(i))"
    "M(i)" "M(f)" using ordertype_exists by blast
  moreover from calculation
  have "i = ordertype(A,r)" using ordertypes_are_absolute by force
  moreover from calculation
  have "ordermap(A,r) ∈ ord_iso(A, r, i, Memrel(i))"
    using ordertype_ord_iso by simp
  ultimately
  have "f = ordermap(A,r)" using well_ord_iso_unique by fastforce
  with ‹M(f)›
  show ?thesis by simp
qed


(*A general fact about ordermap*)
lemma ordermap_eqpoll_pred:
  "[| well_ord(A,r);  x ∈ A ; M(A);M(r);M(x)|] ==> ordermap(A,r)`x ≈⇗M⇖ Order.pred(A,x,r)"
  apply (simp add: def_eqpoll_rel)
  apply (rule rexI)
   apply (simp add: ordermap_eq_image well_ord_is_wf)
   apply (erule ordermap_bij [THEN bij_is_inj, THEN restrict_bij,
        THEN bij_converse_bij])
   apply (rule pred_subset, simp)
  done

text‹Kunen: "each term‹⟨x,y⟩ ∈ K × K› has no more than term‹z × z› predecessors..." (page 29)›
lemma ordermap_csquare_le:
  assumes K: "Limit(K)" and x: "x<K" and y: " y<K"
    and types: "M(K)" "M(x)" "M(y)"
  shows "|ordermap(K × K, csquare_rel(K)) ` ⟨x,y⟩|⇗M⇖ ≤ |succ(succ(x ∪ y))|⇗M⇖ ⊗⇗M⇖ |succ(succ(x ∪ y))|⇗M⇖"
  using types
proof (simp add: cmult_rel_def, rule_tac well_ord_lepoll_rel_imp_cardinal_rel_le)
  let ?z="succ(x ∪ y)"
  show "well_ord(|succ(?z)|⇗M⇖ × |succ(?z)|⇗M⇖,
                 rmult(|succ(?z)|⇗M⇖, Memrel(|succ(?z)|⇗M⇖), |succ(?z)|⇗M⇖, Memrel(|succ(?z)|⇗M⇖)))"
    by (blast intro: well_ord_Memrel well_ord_rmult types)
next
  let ?z="succ(x ∪ y)"
  have zK: "?z<K" using x y K
    by (blast intro: Un_least_lt Limit_has_succ)
  hence oz: "Ord(?z)" by (elim ltE)
  from assms
  have Mom:"M(ordermap(K × K, csquare_rel(K)))"
    using well_ord_csquare Limit_is_Ord by fastforce
  then
  have "ordermap(K × K, csquare_rel(K)) ` ⟨x,y⟩ ≲⇗M⇖ ordermap(K × K, csquare_rel(K)) ` ⟨?z,?z⟩"
    by (blast intro: ordermap_z_lt leI le_imp_lepoll_rel K x y types)
  also have "... ≈⇗M⇖  Order.pred(K × K, ⟨?z,?z⟩, csquare_rel(K))"
  proof (rule ordermap_eqpoll_pred)
    show "well_ord(K × K, csquare_rel(K))" using K
      by (rule Limit_is_Ord [THEN well_ord_csquare])
  next
    show "⟨?z, ?z⟩ ∈ K × K" using zK
      by (blast intro: ltD)
  qed (simp_all add:types)
  also have "...  ≲⇗M⇖ succ(?z) × succ(?z)" using zK
    by (rule_tac pred_csquare_subset [THEN subset_imp_lepoll_rel]) (simp_all add:types)
  also have "... ≈⇗M⇖ |succ(?z)|⇗M⇖ × |succ(?z)|⇗M⇖" using oz
    by (blast intro: prod_eqpoll_rel_cong Ord_cardinal_rel_eqpoll_rel eqpoll_rel_sym types)
  finally show "ordermap(K × K, csquare_rel(K)) ` ⟨x,y⟩ ≲⇗M⇖ |succ(?z)|⇗M⇖ × |succ(?z)|⇗M⇖"
    by (simp_all add:types Mom)
  from Mom
  show "M(ordermap(K × K, csquare_rel(K)) ` ⟨x, y⟩)" by (simp_all add:types)
qed (simp_all add:types)

text‹Kunen: "... so the order type is ‹≤› K"›
lemma ordertype_csquare_le_M:
  assumes IK: "InfCard⇗M⇖(K)" and eq: "⋀y. y∈K ⟹ InfCard⇗M⇖(y) ⟹ M(y) ⟹ y ⊗⇗M⇖ y = y"
    ― ‹Note the weakened hypothesis @{thm eq}›
    and types: "M(K)"
  shows "ordertype(K*K, csquare_rel(K)) ≤ K"
proof -
  have  CK: "Card⇗M⇖(K)" using IK by (rule_tac InfCard_rel_is_Card_rel) (simp_all add:types)
  hence OK: "Ord(K)"  by (rule Card_rel_is_Ord) (simp_all add:types)
  moreover have "Ord(ordertype(K × K, csquare_rel(K)))" using OK
    by (rule well_ord_csquare [THEN Ord_ordertype])
  ultimately show ?thesis
  proof (rule all_lt_imp_le)
    fix i
    assume i:"i < ordertype(K × K, csquare_rel(K))"
    hence Oi: "Ord(i)" by (elim ltE)
    obtain x y where x: "x ∈ K" and y: "y ∈ K"
      and ieq: "i = ordermap(K × K, csquare_rel(K)) ` ⟨x,y⟩"
      using i by (auto simp add: ordertype_unfold elim: ltE)
    hence xy: "Ord(x)" "Ord(y)" "x < K" "y < K" using OK
      by (blast intro: Ord_in_Ord ltI)+
    hence ou: "Ord(x ∪ y)"
      by (simp)
    from OK types
    have "M(ordertype(K × K, csquare_rel(K)))"
      using well_ord_csquare by fastforce
    with i x y types
    have types': "M(K)" "M(i)" "M(x)" "M(y)"
      using types by (auto dest:transM ltD)
    show "i < K"
    proof (rule Card_rel_lt_imp_lt [OF _ Oi CK])
      have "|i|⇗M⇖ ≤ |succ(succ(x ∪ y))|⇗M⇖ ⊗⇗M⇖ |succ(succ(x ∪ y))|⇗M⇖" using IK xy
        by (auto simp add: ieq types intro: InfCard_rel_is_Limit [THEN ordermap_csquare_le] types')
      moreover have "|succ(succ(x ∪ y))|⇗M⇖ ⊗⇗M⇖ |succ(succ(x ∪ y))|⇗M⇖ < K"
      proof (cases rule: Ord_linear2 [OF ou Ord_nat])
        assume "x ∪ y < nat"
        hence "|succ(succ(x ∪ y))|⇗M⇖ ⊗⇗M⇖ |succ(succ(x ∪ y))|⇗M⇖ ∈ nat"
          by (simp add: lt_def nat_cmult_rel_eq_mult nat_succI
              nat_into_Card_rel [THEN Card_rel_cardinal_rel_eq] types')
        also have "... ⊆ K" using IK
          by (simp add: InfCard_rel_def le_imp_subset types)
        finally show "|succ(succ(x ∪ y))|⇗M⇖ ⊗⇗M⇖ |succ(succ(x ∪ y))|⇗M⇖ < K"
          by (simp add: ltI OK)
      next
        assume natxy: "nat ≤ x ∪ y"
        hence seq: "|succ(succ(x ∪ y))|⇗M⇖ = |x ∪ y|⇗M⇖" using xy
          by (simp add: le_imp_subset nat_succ_eqpoll_rel [THEN cardinal_rel_cong] le_succ_iff types')
        also have "... < K" using xy
          by (simp add: Un_least_lt Ord_cardinal_rel_le [THEN lt_trans1] types')
        finally have "|succ(succ(x ∪ y))|⇗M⇖ < K" .
        moreover have "InfCard⇗M⇖(|succ(succ(x ∪ y))|⇗M⇖)" using xy natxy
          by (simp add: seq InfCard_rel_def nat_le_cardinal_rel types')
        ultimately show ?thesis by (simp add: eq ltD types')
      qed
      ultimately show "|i|⇗M⇖ < K" by (blast intro: lt_trans1)
    qed (simp_all add:types')
  qed
qed

(*Main result: Kunen's Theorem 10.12*)
lemma InfCard_rel_csquare_eq:
  assumes IK: "InfCard⇗M⇖(K)" and
    types: "M(K)"
  shows "K ⊗⇗M⇖ K = K"
proof -
  have  OK: "Ord(K)" using IK by (simp add: Card_rel_is_Ord InfCard_rel_is_Card_rel types)
  from OK assms
  show "K ⊗⇗M⇖ K = K"
  proof (induct rule: trans_induct)
    case (step i)
    note types = ‹M(K)› ‹M(i)›
    show "i ⊗⇗M⇖ i = i"
    proof (rule le_anti_sym)
      from step types
      have Mot:"M(ordertype(i × i, csquare_rel(i)))" "M(ordermap(i × i, csquare_rel(i)))"
        using well_ord_csquare Limit_is_Ord by simp_all
      then
      have "|i × i|⇗M⇖ = |ordertype(i × i, csquare_rel(i))|⇗M⇖"
        by (rule_tac cardinal_rel_cong,
            simp_all add: step.hyps well_ord_csquare [THEN ordermap_bij, THEN bij_imp_eqpoll_rel] types)
      with Mot
      have "i ⊗⇗M⇖ i ≤ ordertype(i × i, csquare_rel(i))"
        by (simp add: step.hyps cmult_rel_def Ord_cardinal_rel_le well_ord_csquare [THEN Ord_ordertype] types)
      moreover
      have "ordertype(i × i, csquare_rel(i)) ≤ i" using step
        by (rule_tac ordertype_csquare_le_M) (simp add: types)
      ultimately show "i ⊗⇗M⇖ i ≤ i" by (rule le_trans)
    next
      show "i ≤ i ⊗⇗M⇖ i" using step
        by (blast intro: cmult_rel_square_le InfCard_rel_is_Card_rel)
    qed
  qed
qed


(*Corollary for arbitrary well-ordered sets (all sets, assuming AC)*)
lemma well_ord_InfCard_rel_square_eq:
  assumes r: "well_ord(A,r)" and I: "InfCard⇗M⇖(|A|⇗M⇖)" and
    types: "M(A)" "M(r)"
  shows "A × A ≈⇗M⇖ A"
proof -
  have "A × A ≈⇗M⇖ |A|⇗M⇖ × |A|⇗M⇖"
    by (blast intro: prod_eqpoll_rel_cong well_ord_cardinal_rel_eqpoll_rel eqpoll_rel_sym r types)
  also have "... ≈⇗M⇖ A"
  proof (rule well_ord_cardinal_rel_eqE [OF _ r])
    show "well_ord(|A|⇗M⇖ × |A|⇗M⇖, rmult(|A|⇗M⇖, Memrel(|A|⇗M⇖), |A|⇗M⇖, Memrel(|A|⇗M⇖)))"
      by (blast intro: well_ord_rmult well_ord_Memrel r types)
  next
    show "||A|⇗M⇖ × |A|⇗M⇖|⇗M⇖ = |A|⇗M⇖" using InfCard_rel_csquare_eq I
      by (simp add: cmult_rel_def types)
  qed (simp_all add:types)
  finally show ?thesis by (simp_all add:types)
qed

lemma InfCard_rel_square_eqpoll:
  assumes "InfCard⇗M⇖(K)" and types:"M(K)" shows "K × K ≈⇗M⇖ K"
  using assms
  apply (rule_tac well_ord_InfCard_rel_square_eq)
     apply (erule InfCard_rel_is_Card_rel [THEN Card_rel_is_Ord, THEN well_ord_Memrel])
      apply (simp_all add: InfCard_rel_is_Card_rel [THEN Card_rel_cardinal_rel_eq] types)
  done

lemma Inf_Card_rel_is_InfCard_rel: "[| Card⇗M⇖(i); ~ Finite_rel(M,i) ; M(i) |] ==> InfCard⇗M⇖(i)"
  by (simp add: InfCard_rel_def Card_rel_is_Ord [THEN nat_le_infinite_Ord])

subsubsection‹Toward's Kunen's Corollary 10.13 (1)›

lemma InfCard_rel_le_cmult_rel_eq: "[| InfCard⇗M⇖(K);  L ≤ K;  0<L; M(K) ; M(L) |] ==> K ⊗⇗M⇖ L = K"
  apply (rule le_anti_sym)
   prefer 2
   apply (erule ltE, blast intro: cmult_rel_le_self InfCard_rel_is_Card_rel)
  apply (frule InfCard_rel_is_Card_rel [THEN Card_rel_is_Ord, THEN le_refl]) prefer 3
    apply (rule cmult_rel_le_mono [THEN le_trans], assumption+)
    apply (simp_all add: InfCard_rel_csquare_eq)
  done

(*Corollary 10.13 (1), for cardinal multiplication*)
lemma InfCard_rel_cmult_rel_eq: "[| InfCard⇗M⇖(K);  InfCard⇗M⇖(L); M(K) ; M(L) |] ==> K ⊗⇗M⇖ L = K ∪ L"
  apply (rule_tac i = K and j = L in Ord_linear_le)
     apply (typecheck add: InfCard_rel_is_Card_rel Card_rel_is_Ord)
   apply (rule cmult_rel_commute [THEN ssubst]) prefer 3
     apply (rule Un_commute [THEN ssubst])
     apply (simp_all add: InfCard_rel_is_Limit [THEN Limit_has_0] InfCard_rel_le_cmult_rel_eq
      subset_Un_iff2 [THEN iffD1] le_imp_subset)
  done

lemma InfCard_rel_cdouble_eq: "InfCard⇗M⇖(K) ⟹ M(K) ⟹  K ⊕⇗M⇖ K = K"
  apply (simp add: cmult_rel_2 [symmetric] InfCard_rel_is_Card_rel cmult_rel_commute)
  apply (simp add: InfCard_rel_le_cmult_rel_eq InfCard_rel_is_Limit Limit_has_0 Limit_has_succ)
  done

(*Corollary 10.13 (1), for cardinal addition*)
lemma InfCard_rel_le_cadd_rel_eq: "[| InfCard⇗M⇖(K);  L ≤ K ; M(K) ; M(L)|] ==> K ⊕⇗M⇖ L = K"
  apply (rule le_anti_sym)
   prefer 2
   apply (erule ltE, blast intro: cadd_rel_le_self InfCard_rel_is_Card_rel)
  apply (frule InfCard_rel_is_Card_rel [THEN Card_rel_is_Ord, THEN le_refl]) prefer 3
    apply (rule cadd_rel_le_mono [THEN le_trans], assumption+)
    apply (simp_all add: InfCard_rel_cdouble_eq)
  done

lemma InfCard_rel_cadd_rel_eq: "[| InfCard⇗M⇖(K);  InfCard⇗M⇖(L); M(K) ; M(L) |] ==> K ⊕⇗M⇖ L = K ∪ L"
  apply (rule_tac i = K and j = L in Ord_linear_le)
     apply (typecheck add: InfCard_rel_is_Card_rel Card_rel_is_Ord)
   apply (rule cadd_rel_commute [THEN ssubst]) prefer 3
     apply (rule Un_commute [THEN ssubst])
     apply (simp_all add: InfCard_rel_le_cadd_rel_eq subset_Un_iff2 [THEN iffD1] le_imp_subset)
  done

(*The other part, Corollary 10.13 (2), refers to the cardinality of the set
  of all n-tuples of elements of K.  A better version for the Isabelle theory
  might be  InfCard(K) ==> |list(K)| = K.
*)

end ― ‹locale‹M_cardinal_arith››

subsection‹For Every Cardinal Number There Exists A Greater One›

text‹This result is Kunen's Theorem 10.16, which would be trivial using AC›

locale M_cardinal_arith_jump = M_cardinal_arith + M_ordertype
begin

lemma well_ord_restr: "well_ord(X, r) ⟹ well_ord(X, r ∩ X×X)"
proof -
  have "r ∩ X×X ∩ X×X = r ∩ X×X" by auto
  moreover
  assume "well_ord(X, r)"
  ultimately
  show ?thesis
    unfolding well_ord_def tot_ord_def part_ord_def linear_def
      irrefl_def wf_on_def
    by simp_all (simp only: trans_on_def, blast)
qed

lemma ordertype_restr_eq :
  assumes "well_ord(X,r)"
  shows "ordertype(X, r) = ordertype(X, r ∩ X×X)"
  using ordermap_restr_eq assms unfolding ordertype_def
  by simp

lemma def_jump_cardinal_rel_aux:
  "X ∈ Pow⇗M⇖(K) ⟹ well_ord(X, w) ⟹ M(K) ⟹
  {z . r ∈ Pow⇗M⇖(X × X), M(z) ∧ well_ord(X, r) ∧ z = ordertype(X, r)} =
  {z . r ∈ Pow⇗M⇖(K × K), M(z) ∧ well_ord(X, r) ∧ z = ordertype(X, r)}"
proof(rule,auto simp:Pow_rel_char dest:transM)
  let ?L="{z . r ∈ Pow⇗M⇖(X × X), M(z) ∧ well_ord(X, r) ∧ z = ordertype(X, r)}"
  let ?R="{z . r ∈ Pow⇗M⇖(K × K), M(z) ∧ well_ord(X, r) ∧ z = ordertype(X, r)}"
  show "ordertype(X, r) ∈ {y . x ∈ {x ∈ Pow(X × X) . M(x)}, M(y) ∧ well_ord(X, x) ∧ y = ordertype(X, x)}"
    if "M(K)" "M(r)" "r⊆K×K" "X⊆K" "M(X)" "well_ord(X,r)" for r
  proof -
    from that
    have "ordertype(X,r) = ordertype(X,r∩X×X)" "(r∩X×X)⊆X×X" "M(r∩X×X)"
      "well_ord(X,r∩X×X)" "wellordered(M,X,r∩X×X)"
      using well_ord_restr ordertype_restr_eq by auto
    moreover from this
    have "ordertype(X,r∩X×X) ∈ ?L"
      using that Pow_rel_char
        ReplaceI[of "λ z r . M(z) ∧ well_ord(X, r) ∧ z = ordertype(X, r)" "ordertype(X,r∩X×X)"]
      by auto
    ultimately
    show ?thesis using Pow_rel_char by auto
  qed
qed

lemma def_jump_cardinal_rel:
  assumes "M(K)"
  shows "jump_cardinal'_rel(M,K) =
         (⋃X∈Pow_rel(M,K). {z. r ∈ Pow_rel(M,K*K), well_ord(X,r) & z = ordertype(X,r)})"
proof -
  have "M({z . r ∈ Pow⇗M⇖(X × X), M(z) ∧ well_ord(X, r) ∧ z = ordertype(X, r)})"
    (is "M(Replace(_,?P))")
    if "M(X)" for X
    using that jump_cardinal_closed_aux1[of X] ordertype_rel_abs[of X]
      jump_cardinal_body_def
    by (subst Replace_cong[where P="?P"
          and Q="λr z. M(z) ∧ M(r) ∧ well_ord(X, r) ∧ z = ordertype_rel(M,X,r)",
          OF refl, of "Pow⇗M⇖(X × X)"]) (auto dest:transM)
  then
  have "M({z . r ∈ Pow⇗M⇖(Y × Y), M(z) ∧ well_ord(X, r) ∧ z = ordertype(X, r)})"
    if "M(Y)" "M(X)" "X ∈ Pow⇗M⇖(Y)" "well_ord(X,r)" for Y X r
    using that def_jump_cardinal_rel_aux[of X Y r, symmetric] by simp
  moreover from ‹M(K)›
  have "R ∈ Pow⇗M⇖(X × X) ⟹ X ∈ Pow⇗M⇖(K) ⟹ R ∈ Pow⇗M⇖(K × K)"
    for X R using mem_Pow_rel_abs transM[OF _ Pow_rel_closed, of R "X×X"]
      transM[OF _ Pow_rel_closed, of X K] by auto
  ultimately
  show ?thesis
    using assms is_ordertype_iff is_well_ord_iff_wellordered
      ordertype_rel_abs transM[of _ "Pow⇗M⇖(K)"] transM[of _ "Pow⇗M⇖(K×K)"]
      def_jump_cardinal_rel_aux
    unfolding jump_cardinal'_rel_def
    apply (intro equalityI)
     apply (auto dest:transM)
     apply (rename_tac X R)
     apply (rule_tac x=X in bexI)
      apply (rule_tac x=R in ReplaceI)
        apply auto
    apply (rule_tac x="{y . xa ∈ Pow⇗M⇖(K × K), M(y) ∧ M(xa) ∧ well_ord(X, xa) ∧ y = ordertype(X, xa)}" in bexI)
     apply auto
    by (rule_tac x=X in ReplaceI) auto
qed

notation jump_cardinal'_rel (‹jump'_cardinal'_rel›)

lemma Ord_jump_cardinal_rel: "M(K) ⟹ Ord(jump_cardinal_rel(M,K))"
  apply (unfold def_jump_cardinal_rel)
  apply (rule Ord_is_Transset [THEN [2] OrdI])
   prefer 2 apply (blast intro!: Ord_ordertype)
  apply (unfold Transset_def)
  apply (safe del: subsetI)
  apply (subst ordertype_pred_unfold, simp, safe)
  apply (rule UN_I)
   apply (rule_tac [2] ReplaceI)
     prefer 4 apply (blast intro: well_ord_subset elim!: predE, simp_all)
   prefer 2 apply (blast intro: well_ord_subset elim!: predE)
proof -
  fix X r xb
  assume "M(K)" "X ∈ Pow⇗M⇖(K)" "r ∈ Pow⇗M⇖(K × K)" "well_ord(X, r)" "xb ∈ X"
  moreover from this
  have "M(X)" "M(r)"
    using cartprod_closed trans_Pow_rel_closed by auto
  moreover from this
  have "M(xb)" using transM[OF ‹xb∈X›] by simp
  ultimately
  show "Order.pred(X, xb, r) ∈ Pow⇗M⇖(K)"
    using def_Pow_rel by (auto dest:predE)
qed

declare conj_cong [cong del]
  ― ‹incompatible with some of the proofs of the original theory›

lemma jump_cardinal_rel_iff_old:
  "M(i) ⟹ M(K) ⟹ i ∈ jump_cardinal_rel(M,K) ⟷
      (∃r[M]. ∃X[M]. r ⊆ K*K & X ⊆ K & well_ord(X,r) & i = ordertype(X,r))"
  apply (unfold def_jump_cardinal_rel)
  apply (auto del: subsetI)
   apply (rename_tac y r)
   apply (rule_tac x=r in rexI, intro conjI) prefer 2
     apply (rule_tac x=y in rexI, intro conjI)
        apply (auto dest:mem_Pow_rel transM)
   apply (rule_tac A=r in rev_subsetD, assumption)
   defer
   apply (rename_tac r y)
   apply (rule_tac x=y in bexI)
    apply (rule_tac x=r in ReplaceI, auto)
  using def_Pow_rel
    apply (force+)[2]
  apply (rule_tac A=r in rev_subsetD, assumption)
  using mem_Pow_rel[THEN conjunct1]
  apply auto
  done

(*The easy part of Theorem 10.16: jump_cardinal_rel(K) exceeds K*)
lemma K_lt_jump_cardinal_rel: "Ord(K) ==> M(K) ⟹ K < jump_cardinal_rel(M,K)"
  apply (rule Ord_jump_cardinal_rel [THEN [2] ltI])
   apply (rule jump_cardinal_rel_iff_old [THEN iffD2], assumption+)
   apply (rule_tac x="Memrel(K)" in rexI)
    apply (rule_tac x=K in rexI)
     apply (simp add: ordertype_Memrel well_ord_Memrel)
  using Memrel_closed
     apply (simp_all add: Memrel_def subset_iff)
  done

(*The proof by contradiction: the bijection f yields a wellordering of X
  whose ordertype is jump_cardinal_rel(K).  *)
lemma Card_rel_jump_cardinal_rel_lemma:
  "[| well_ord(X,r);  r ⊆ K * K;  X ⊆ K;
         f ∈ bij(ordertype(X,r), jump_cardinal_rel(M,K));
         M(X); M(r); M(K); M(f) |]
      ==> jump_cardinal_rel(M,K) ∈ jump_cardinal_rel(M,K)"
  apply (subgoal_tac "f O ordermap (X,r) ∈ bij (X, jump_cardinal_rel (M,K))")
   prefer 2 apply (blast intro: comp_bij ordermap_bij)
  apply (rule jump_cardinal_rel_iff_old [THEN iffD2], simp+)
  apply (intro rexI conjI)
       apply (rule subset_trans [OF rvimage_type Sigma_mono], assumption+)
     apply (erule bij_is_inj [THEN well_ord_rvimage])
     apply (rule Ord_jump_cardinal_rel [THEN well_ord_Memrel])
     apply (simp_all add: well_ord_Memrel [THEN [2] bij_ordertype_vimage]
      ordertype_Memrel Ord_jump_cardinal_rel)
  done

(*The hard part of Theorem 10.16: jump_cardinal_rel(K) is itself a cardinal*)
lemma Card_rel_jump_cardinal_rel: "M(K) ⟹ Card_rel(M,jump_cardinal_rel(M,K))"
  apply (rule Ord_jump_cardinal_rel [THEN Card_relI])
    apply (simp_all add: def_eqpoll_rel)
  apply (drule_tac i1=j in jump_cardinal_rel_iff_old [THEN iffD1, OF _ _ ltD, of _ K], safe)
  apply (blast intro: Card_rel_jump_cardinal_rel_lemma [THEN mem_irrefl])
  done

subsection‹Basic Properties of Successor Cardinals›

lemma csucc_rel_basic: "Ord(K) ==> M(K) ⟹ Card_rel(M,csucc_rel(M,K)) & K < csucc_rel(M,K)"
  apply (unfold csucc_rel_def)
  apply (rule LeastI[of "λi. M(i) ∧ Card_rel(M,i) ∧ K < i", THEN conjunct2])
   apply (blast intro: Card_rel_jump_cardinal_rel K_lt_jump_cardinal_rel Ord_jump_cardinal_rel)+
  done

lemmas Card_rel_csucc_rel = csucc_rel_basic [THEN conjunct1]

lemmas lt_csucc_rel = csucc_rel_basic [THEN conjunct2]

lemma Ord_0_lt_csucc_rel: "Ord(K) ==> M(K) ⟹ 0 < csucc_rel(M,K)"
  by (blast intro: Ord_0_le lt_csucc_rel lt_trans1)

lemma csucc_rel_le: "[| Card_rel(M,L);  K<L; M(K); M(L) |] ==> csucc_rel(M,K) ≤ L"
  apply (unfold csucc_rel_def)
  apply (rule Least_le)
   apply (blast intro: Card_rel_is_Ord)+
  done

lemma lt_csucc_rel_iff: "[| Ord(i); Card_rel(M,K); M(K); M(i)|] ==> i < csucc_rel(M,K) ⟷ |i|⇗M⇖ ≤ K"
  apply (rule iffI)
   apply (rule_tac [2] Card_rel_lt_imp_lt)
       apply (erule_tac [2] lt_trans1)
       apply (simp_all add: lt_csucc_rel Card_rel_csucc_rel Card_rel_is_Ord)
  apply (rule notI [THEN not_lt_imp_le])
    apply (rule Card_rel_cardinal_rel [THEN csucc_rel_le, THEN lt_trans1, THEN lt_irrefl], simp_all+)
   apply (rule Ord_cardinal_rel_le [THEN lt_trans1])
     apply (simp_all add: Card_rel_is_Ord)
  done

lemma Card_rel_lt_csucc_rel_iff:
  "[| Card_rel(M,K'); Card_rel(M,K); M(K'); M(K) |] ==> K' < csucc_rel(M,K) ⟷ K' ≤ K"
  by (simp add: lt_csucc_rel_iff Card_rel_cardinal_rel_eq Card_rel_is_Ord)

lemma InfCard_rel_csucc_rel: "InfCard_rel(M,K) ⟹ M(K) ==> InfCard_rel(M,csucc_rel(M,K))"
  by (simp add: InfCard_rel_def Card_rel_csucc_rel Card_rel_is_Ord
      lt_csucc_rel [THEN leI, THEN [2] le_trans])


subsubsection‹Theorems by Krzysztof Grabczewski, proofs by lcp›

lemma nat_sum_eqpoll_rel_sum:
  assumes m: "m ∈ nat" and n: "n ∈ nat" shows "m + n ≈⇗M⇖ m +ω n"
proof -
  have "m + n ≈⇗M⇖ |m+n|⇗M⇖" using m n
    by (blast intro: nat_implies_well_ord well_ord_radd well_ord_cardinal_rel_eqpoll_rel eqpoll_rel_sym)
  also have "... = m +ω n" using m n
    by (simp add: nat_cadd_rel_eq_add [symmetric] cadd_rel_def transM[OF _ M_nat])
  finally show ?thesis .
qed

lemma Ord_nat_subset_into_Card_rel: "[| Ord(i); i ⊆ nat |] ==> Card⇗M⇖(i)"
  by (blast dest: Ord_subset_natD intro: Card_rel_nat nat_into_Card_rel)

end ― ‹locale‹M_cardinal_arith_jump››
end
body>

Theory Aleph_Relative

theory Aleph_Relative
  imports
    CardinalArith_Relative
begin

definition
  HAleph :: "[i,i] ⇒ i" where
  "HAleph(i,r) ≡ if(¬(Ord(i)),i,if(i=0, nat, if(¬Limit(i) ∧ i≠0,
                            csucc(r`( ⋃ i )),
                                   ⋃j∈i. r`j)))"

reldb_add functional "Limit" "Limit"
relationalize "Limit" "is_Limit" external
synthesize "is_Limit" from_definition
arity_theorem for "is_Limit_fm"

relativize functional "HAleph" "HAleph_rel"
relationalize "HAleph_rel" "is_HAleph"

synthesize "is_HAleph" from_definition assuming "nonempty"
arity_theorem intermediate for "is_HAleph_fm"

lemma arity_is_HAleph_fm_aux:
  assumes
    "i ∈ nat" "r ∈ nat"
    ― ‹NOTE: assumptions are ❙‹not› used, but if omitted, next lemma fails!›
  shows
    "arity(Replace_fm(8 +ω i, ⋅10 +ω r`0 is 1⋅, 3)) = 9 +ω i ∪ pred(pred(11 +ω r))"
  using arity_Replace_fm[of "⋅ (10+ωr)`0 is 1⋅" "8+ωi" 3 "(11+ωr) ∪ 1 ∪ 2"]
    ord_simp_union
  by (auto simp:arity)

lemma arity_is_HAleph_fm[arity]:
  assumes
    "i ∈ nat" "r ∈ nat" "l ∈ nat"
  shows
    "arity(is_HAleph_fm(i, r, l)) =  succ(i) ∪ succ(l) ∪ succ(r)"
  using assms pred_Un arity_is_HAleph_fm_aux arity_is_HAleph_fm'
  by auto

definition
  Aleph' :: "i => i"  where
  "Aleph'(a) == transrec(a,λi r. HAleph(i,r))"

relativize functional "Aleph'" "Aleph_rel"
relationalize "Aleph_rel" "is_Aleph"

txt‹The extra assumptions term‹a < length(env)› and term‹c < length(env)›
    in this schematic goal (and the following results on synthesis that
    depend on it) are imposed by @{thm is_transrec_iff_sats}.›
schematic_goal sats_is_Aleph_fm_auto:
  "a ∈ nat ⟹ c ∈ nat ⟹ env ∈ list(A) ⟹
  a < length(env) ⟹ c < length(env) ⟹ 0 ∈ A ⟹
  is_Aleph(##A, nth(a, env), nth(c, env)) ⟷ A, env ⊨ ?fm(a, c)"
  unfolding is_Aleph_def
proof (rule is_transrec_iff_sats, rule_tac [1] is_HAleph_iff_sats)
  fix a0 a1 a2 a3 a4 a5 a6 a7
  let ?env' = "Cons(a0, Cons(a1, Cons(a2, Cons(a3, Cons(a4, Cons(a5, Cons(a6, Cons(a7, env))))))))"
  show "nth(2, ?env') = a2"
    "nth(1, ?env') = a1"
    "nth(0, ?env') = a0"
    "nth(c, env) = nth(c, env)"
    by simp_all
qed simp_all

synthesize_notc "is_Aleph" from_schematic

notation is_Aleph_fm (‹⋅ℵ'(_') is _⋅›)

lemma is_Aleph_fm_type [TC]: "a ∈ nat ⟹ c ∈ nat ⟹ is_Aleph_fm(a, c) ∈ formula"
  unfolding is_Aleph_fm_def by simp

lemma sats_is_Aleph_fm:
  assumes "f∈nat" "r∈nat" "env ∈ list(A)" "0∈A" "f < length(env)" "r< length(env)"
  shows "is_Aleph(##A, nth(f, env), nth(r, env)) ⟷ A, env ⊨ is_Aleph_fm(f,r)"
  using assms sats_is_Aleph_fm_auto unfolding is_Aleph_def is_Aleph_fm_def by simp

lemma is_Aleph_iff_sats [iff_sats]:
  assumes
    "nth(f, env) = fa" "nth(r, env) = ra" "f < length(env)" "r< length(env)"
    "f ∈ nat" "r ∈ nat" "env ∈ list(A)" "0∈A"
  shows "is_Aleph(##A,fa,ra) ⟷ A, env ⊨ is_Aleph_fm(f,r)"
  using assms sats_is_Aleph_fm[of f r env A] by simp

arity_theorem for "is_Aleph_fm"

lemma (in M_cardinal_arith_jump) is_Limit_iff:
  assumes "M(a)"
  shows "is_Limit(M,a) ⟷ Limit(a)"
  unfolding is_Limit_def Limit_def using lt_abs transM[OF ltD ‹M(a)›] assms
  by auto

lemma HAleph_eq_Aleph_recursive:
  "Ord(i) ⟹ HAleph(i,r) = (if i = 0 then nat
                else if ∃j. i = succ(j) then csucc(r ` (THE j. i = succ(j))) else ⋃j<i. r ` j)"
proof -
  assume "Ord(i)"
  moreover from this
  have "i = succ(j) ⟹ (⋃succ(j)) = j" for j
    using Ord_Union_succ_eq by simp
  moreover from ‹Ord(i)›
  have "(∃j. i = succ(j)) ⟷ ¬Limit(i) ∧ i ≠ 0"
    using Ord_cases_disj by auto
  ultimately
  show ?thesis
    unfolding HAleph_def OUnion_def
    by auto
qed

lemma Aleph'_eq_Aleph: "Ord(a) ⟹ Aleph'(a) = Aleph(a)"
  unfolding Aleph'_def Aleph_def transrec2_def
  using HAleph_eq_Aleph_recursive
  by (intro transrec_equal_on_Ord) auto

reldb_rem functional "Aleph'"
reldb_rem relational "is_Aleph"
reldb_add functional "Aleph" "Aleph_rel"
reldb_add relational "Aleph" "is_Aleph"

abbreviation
  Aleph_r :: "[i,i⇒o] ⇒ i" (‹ℵ⇘_⇙⇗_⇖›) where
  "Aleph_r(a,M) ≡ Aleph_rel(M,a)"

abbreviation
  Aleph_r_set :: "[i,i] ⇒ i" (‹ℵ⇘_⇙⇗_⇖›) where
  "Aleph_r_set(a,M) ≡ Aleph_rel(##M,a)"

lemma Aleph_rel_def': "Aleph_rel(M,a) ≡ transrec(a, λi r. HAleph_rel(M, i, r))"
  unfolding Aleph_rel_def .

lemma succ_mem_Limit: "Limit(j) ⟹ i ∈ j ⟹ succ(i) ∈ j"
  using Limit_has_succ[THEN ltD] ltI Limit_is_Ord by auto

locale M_pre_aleph = M_eclose + M_cardinal_arith_jump +
  assumes
    haleph_transrec_replacement: "M(a) ⟹ transrec_replacement(M,is_HAleph(M),a)"

begin

lemma aux_ex_Replace_funapply:
  assumes "M(a)" "M(f)"
  shows "∃x[M]. is_Replace(M, a, λj y. f ` j = y, x)"
proof -
  have "{f`j . j∈a} = {y . j∈a , f ` j=y}"
    "{y . j∈a , f ` j=y} = {y . j∈a , y =f ` j}"
    by auto
  moreover
  note assms
  moreover from calculation
  have "x ∈ a ⟹ y = f `x ⟹ M(y)" for x y
    using transM[OF _ ‹M(a)›] by auto
  moreover from assms
  have "M({f`j . j∈a})"
    using transM[OF _ ‹M(a)›] RepFun_closed[OF apply_replacement] by simp
  ultimately
  have 2:"is_Replace(M, a, λj y. y = f ` j, {f`j . j∈a})"
    using Replace_abs[of _ _ "λj y. y = f ` j",OF ‹M(a)›,THEN iffD2]
    by auto
  with ‹M({f`j . j∈a})›
  show ?thesis
    using
      is_Replace_cong[of _ _ M "λj y. y = f ` j" "λj y. f ` j = y", THEN iffD1,OF _ _ _ 2]
    by auto
qed

lemma is_HAleph_zero:
  assumes "M(f)"
  shows "is_HAleph(M,0,f,res) ⟷ res = nat"
  unfolding is_HAleph_def
  using Ord_0 If_abs is_Limit_iff is_csucc_iff assms aux_ex_Replace_funapply
  by auto

lemma is_HAleph_succ:
  assumes "M(f)" "M(x)" "Ord(x)" "M(res)"
  shows "is_HAleph(M,succ(x),f,res) ⟷ res = csucc_rel(M,f`x)"
  unfolding is_HAleph_def
  using assms is_Limit_iff is_csucc_iff aux_ex_Replace_funapply If_abs Ord_Union_succ_eq
  by simp

lemma is_HAleph_limit:
  assumes "M(f)" "M(x)" "Limit(x)" "M(res)"
  shows "is_HAleph(M,x,f,res) ⟷ res = (⋃{y . i∈x ,M(i) ∧ M(y) ∧ y = f`i})"
proof -
  from assms
  have "univalent(M, x, λj y. y = f ` j  )"
    "(⋀xa y. xa ∈ x ⟹ f ` xa = y ⟹ M(y))"
    "{y . x ∈ x, f ` x = y} = {y . i∈x ,M(i) ∧ M(y) ∧ y = f`i}"
    using univalent_triv[of M x "λj .f ` j"] transM[OF _ ‹M(x)›]
    by auto
  moreover
  from this
  have "univalent(M, x, λj y. f ` j = y )"
    by (rule_tac univalent_cong[of x x M " λj y. y = f ` j" " λj y. f ` j=y",THEN iffD1], auto)
  moreover
  from this
  have "univalent(M, x, λj y. M(j) ∧ M(y) ∧ f ` j = y )"
    by auto
  ultimately
  show ?thesis
    unfolding is_HAleph_def
    using assms is_Limit_iff Limit_is_Ord zero_not_Limit If_abs is_csucc_iff
      Replace_abs apply_replacement
    by auto
qed

lemma is_HAleph_iff:
  assumes "M(a)" "M(f)" "M(res)"
  shows "is_HAleph(M, a, f, res) ⟷ res = HAleph_rel(M, a, f)"
proof(cases "Ord(a)")
  case True
  note Ord_cases[OF ‹Ord(a)›]
  then
  show ?thesis
  proof(cases )
    case 1
    with True assms
    show ?thesis
      using is_HAleph_zero unfolding HAleph_rel_def
      by simp
  next
    case (2 j)
    with True assms
    show ?thesis
      using is_HAleph_succ Ord_Union_succ_eq
      unfolding HAleph_rel_def
      by simp
  next
    case 3
    with assms
    show ?thesis
      using is_HAleph_limit zero_not_Limit Limit_is_Ord
      unfolding HAleph_rel_def
      by auto
  qed
next
  case False
  then
  have "¬Limit(a)" "a≠0" "⋀ x . Ord(x) ⟹ a≠succ(x)"
    using Limit_is_Ord by auto
  with False
  show ?thesis
    unfolding is_HAleph_def HAleph_rel_def
    using assms is_Limit_iff If_abs is_csucc_iff aux_ex_Replace_funapply
    by auto
qed

lemma HAleph_rel_closed [intro,simp]:
  assumes "function(f)" "M(a)" "M(f)"
  shows "M(HAleph_rel(M,a,f))"
  unfolding HAleph_rel_def
  using assms apply_replacement
  by simp

lemma Aleph_rel_closed[intro, simp]:
  assumes "Ord(a)" "M(a)"
  shows "M(Aleph_rel(M,a))"
proof -
  have "relation2(M, is_HAleph(M), HAleph_rel(M))"
    unfolding relation2_def using is_HAleph_iff assms by simp
  moreover
  have "∀x[M]. ∀g[M]. function(g) ⟶ M(HAleph_rel(M, x, g))"
    using HAleph_rel_closed by simp
  moreover
  note assms
  ultimately
  show ?thesis
    unfolding Aleph_rel_def
    using transrec_closed[of "is_HAleph(M)" a "HAleph_rel(M)"]
      haleph_transrec_replacement  by simp
qed

lemma Aleph_rel_zero: "ℵ⇘0⇙⇗M⇖ = nat"
  using def_transrec [OF Aleph_rel_def',of _ 0]
  unfolding HAleph_rel_def by simp

lemma Aleph_rel_succ: "Ord(α) ⟹ M(α) ⟹ ℵ⇘succ(α)⇙⇗M⇖ = (ℵ⇘α⇙⇗M⇖+)⇗M⇖"
  using Ord_Union_succ_eq
  by (subst def_transrec [OF Aleph_rel_def'])
    (simp add:HAleph_rel_def)

lemma Aleph_rel_limit:
  assumes "Limit(α)" "M(α)"
  shows "ℵ⇘α⇙⇗M⇖ = ⋃{ℵ⇘j⇙⇗M⇖ . j ∈ α}"
proof -
  note trans=transM[OF _ ‹M(α)›]
  from ‹M(α)›
  have "ℵ⇘α⇙⇗M⇖ = HAleph_rel(M, α, λx∈α. ℵ⇘x⇙⇗M⇖)"
    using def_transrec [OF Aleph_rel_def',of M α] by simp
  also
  have "... = ⋃{a . j ∈ α, M(a) ∧ a = ℵ⇘j⇙⇗M⇖}"
    unfolding HAleph_rel_def
    using assms zero_not_Limit Limit_is_Ord trans by auto
  also
  have "... = ⋃{ℵ⇘j⇙⇗M⇖ . j ∈ α}"
    using Aleph_rel_closed[OF _ trans] Ord_in_Ord Limit_is_Ord[OF ‹Limit(α)›] by auto
  finally
  show ?thesis .
qed

lemma is_Aleph_iff:
  assumes "Ord(a)" "M(a)" "M(res)"
  shows "is_Aleph(M, a, res) ⟷ res = ℵ⇘a⇙⇗M⇖"
proof -
  have "relation2(M, is_HAleph(M), HAleph_rel(M))"
    unfolding relation2_def using is_HAleph_iff assms by simp
  moreover
  have "∀x[M]. ∀g[M]. function(g) ⟶ M(HAleph_rel(M, x, g))"
    using HAleph_rel_closed by simp
  ultimately
  show ?thesis
    using assms transrec_abs haleph_transrec_replacement
    unfolding is_Aleph_def Aleph_rel_def
    by simp
qed

end ― ‹locale‹M_pre_aleph››

locale M_aleph = M_pre_aleph +
  assumes
    aleph_rel_replacement: "strong_replacement(M, λx y. Ord(x) ∧ y = ℵ⇘x⇙⇗M⇖)"
begin

lemma Aleph_rel_cont: "Limit(l) ⟹ M(l) ⟹ ℵ⇘l⇙⇗M⇖ = (⋃i<l. ℵ⇘i⇙⇗M⇖)"
  using Limit_is_Ord Aleph_rel_limit
  by (simp add:OUnion_def)

lemma Ord_Aleph_rel:
  assumes "Ord(a)"
  shows "M(a) ⟹ Ord(ℵ⇘a⇙⇗M⇖)"
  using ‹Ord(a)›
proof(induct a rule:trans_induct3)
  case 0
  show ?case using Aleph_rel_zero by simp
next
  case (succ x)
  with ‹Ord(x)›
  have "M(x)" "Ord(ℵ⇘x⇙⇗M⇖)" by simp_all
  with ‹Ord(x)›
  have "Ord(csucc_rel(M,ℵ⇘x⇙⇗M⇖))"
    using Card_rel_is_Ord Card_rel_csucc_rel
    by simp
  with ‹Ord(x)› ‹M(x)›
  show ?case using Aleph_rel_succ by simp
next
  case (limit x)
  note trans=transM[OF _ ‹M(x)›]
  from limit
  have "ℵ⇘x⇙⇗M⇖ = (⋃i∈x. ℵ⇘i⇙⇗M⇖)"
    using Aleph_rel_cont OUnion_def Limit_is_Ord
    by auto
  with limit
  show ?case using Ord_UN trans by auto
qed

lemma Card_rel_Aleph_rel [simp, intro]:
  assumes "Ord(a)" and types: "M(a)" shows "Card⇗M⇖(ℵ⇘a⇙⇗M⇖)"
  using assms
proof (induct rule:trans_induct3)
  case 0
  then
  show ?case
    using Aleph_rel_zero Card_rel_nat by simp
next
  case (succ x)
  then
  show ?case
    using Card_rel_csucc_rel Ord_Aleph_rel Aleph_rel_succ
    by simp
next
  case (limit x)
  moreover
  from this
  have "M({y . z ∈ x, M(y) ∧ M(z) ∧ Ord(z) ∧ y = ℵ⇘z⇙⇗M⇖})"
    using aleph_rel_replacement
    by auto
  moreover
  have "{y . z ∈ x, M(y) ∧ M(z) ∧ y = ℵ⇘z⇙⇗M⇖} = {y . z ∈ x, M(y) ∧ M(z) ∧ Ord(z) ∧ y = ℵ⇘z⇙⇗M⇖}"
    using Ord_in_Ord Limit_is_Ord[OF limit(1)] by simp
  ultimately
  show ?case
    using Ord_Aleph_rel Card_nat Limit_is_Ord Card_relI
    by (subst def_transrec [OF Aleph_rel_def'])
      (auto simp add:HAleph_rel_def)
qed

lemma Aleph_rel_increasing:
  assumes "a < b" and types: "M(a)" "M(b)"
  shows "ℵ⇘a⇙⇗M⇖ < ℵ⇘b⇙⇗M⇖"
proof -
  { fix x
    from assms
    have "Ord(b)"
      by (blast intro: lt_Ord2)
    moreover
    assume "M(x)"
    moreover
    note ‹M(b)›
    ultimately
    have "x < b ⟹ ℵ⇘x⇙⇗M⇖ < ℵ⇘b⇙⇗M⇖"
    proof (induct b arbitrary: x rule: trans_induct3)
      case 0 thus ?case by simp
    next
      case (succ b)
      then
      show ?case
        using Card_rel_csucc_rel Ord_Aleph_rel Ord_Union_succ_eq lt_csucc_rel
          lt_trans[of _ "ℵ⇘b⇙⇗M⇖" "csucc⇗M⇖(ℵ⇘b⇙⇗M⇖)"]
        by (subst (2) def_transrec[OF Aleph_rel_def'])
          (auto simp add: le_iff HAleph_rel_def)
    next
      case (limit l)
      then
      have sc: "succ(x) < l"
        by (blast intro: Limit_has_succ)
      then
      have "ℵ⇘x⇙⇗M⇖ < (⋃j<l. ℵ⇘j⇙⇗M⇖)"
        using limit Ord_Aleph_rel Ord_OUN
      proof(rule_tac OUN_upper_lt,blast intro: Card_rel_is_Ord ltD lt_Ord)
        from ‹x<l› ‹Limit(l)›
        have "Ord(x)"
          using Limit_is_Ord Ord_in_Ord
          by (auto dest!:ltD)
        with ‹M(x)›
        show "ℵ⇘x⇙⇗M⇖ < ℵ⇘succ(x)⇙⇗M⇖"
          using Card_rel_csucc_rel Ord_Aleph_rel lt_csucc_rel
            ltD[THEN [2] Ord_in_Ord] succ_in_MI[OF ‹M(x)›]
            Aleph_rel_succ[of x]
          by (simp)
      next
        from ‹M(l)› ‹Limit(l)›
        show "Ord(⋃j<l. ℵ⇘j⇙⇗M⇖)"
          using Ord_Aleph_rel lt_Ord Limit_is_Ord Ord_in_Ord
          by (rule_tac Ord_OUN)
            (auto dest:transM ltD intro!:Ord_Aleph_rel)
      qed
      then
      show ?case using limit Aleph_rel_cont by simp
    qed
  }
  with types assms
  show ?thesis by simp
qed

lemmas nat_subset_Aleph_rel_1 =
  Ord_lt_subset[OF Ord_Aleph_rel[of 1] Aleph_rel_increasing[of 0 1,simplified],simplified]

end ― ‹locale‹M_aleph››

end
d>

Theory Cardinal_AC_Relative

section‹Relative, Cardinal Arithmetic Using AC›

theory Cardinal_AC_Relative
  imports
    CardinalArith_Relative

begin

locale M_AC =
  fixes M
  assumes
    choice_ax: "choice_ax(M)"

locale M_cardinal_AC = M_cardinal_arith + M_AC
begin

lemma well_ord_surj_imp_lepoll_rel:
  assumes "well_ord(A,r)" "h ∈ surj(A,B)" and
    types:"M(A)" "M(r)" "M(h)" "M(B)"
  shows "B ≲⇗M⇖ A"
proof -
  note eq=vimage_fun_sing[OF surj_is_fun[OF ‹h∈_›]]
  from assms
  have "(λb∈B. minimum(r, {a∈A. h`a=b})) ∈ inj(B,A)" (is "?f∈_")
    using well_ord_surj_imp_inj_inverse assms(1,2) by simp
  with assms
  have "M(?f`b)" if "b∈B" for b
    using apply_type[OF inj_is_fun[OF ‹?f∈_›]] that transM[OF _ ‹M(A)›] by simp
  with assms
  have "M(?f)"
    using lam_closed surj_imp_inj_replacement4 eq by auto
  with ‹?f∈_› assms
  have "?f ∈ inj⇗M⇖(B,A)"
    using mem_inj_abs by simp
  with ‹M(?f)›
  show ?thesis unfolding lepoll_rel_def by auto
qed

lemma surj_imp_well_ord_M:
  assumes wos: "well_ord(A,r)" "h ∈ surj(A,B)"
    and
    types: "M(A)" "M(r)" "M(h)" "M(B)"
  shows "∃s[M]. well_ord(B,s)"
  using assms lepoll_rel_well_ord
    well_ord_surj_imp_lepoll_rel by fast


lemma choice_ax_well_ord: "M(S) ⟹ ∃r[M]. well_ord(S,r)"
  using choice_ax well_ord_Memrel[THEN surj_imp_well_ord_M]
  unfolding choice_ax_def by auto

lemma Finite_cardinal_rel_Finite:
  assumes "Finite(|i|⇗M⇖)" "M(i)"
  shows "Finite(i)"
proof -
  note assms
  moreover from this
  obtain r where "M(r)" "well_ord(i,r)"
    using choice_ax_well_ord by auto
  moreover from calculation
  have "|i|⇗M⇖ ≈⇗M⇖ i"
    using well_ord_cardinal_rel_eqpoll_rel
    by auto
  ultimately
  show ?thesis
    using eqpoll_rel_imp_Finite
    by auto
qed

end ― ‹locale‹M_cardinal_AC››

locale M_Pi_assumptions_choice = M_Pi_assumptions + M_cardinal_AC +
  assumes
    B_replacement: "strong_replacement(M, λx y. y = B(x))"
    and
    ― ‹The next one should be derivable from (some variant)
        of B\_replacement. Proving both instances each time seems
        inconvenient.›
    minimum_replacement: "M(r) ⟹ strong_replacement(M, λx y. y = ⟨x, minimum(r, B(x))⟩)"
begin

lemma AC_M:
  assumes "a ∈ A" "⋀x. x ∈ A ⟹ ∃y. y ∈ B(x)"
  shows "∃z[M]. z ∈ Pi⇗M⇖(A, B)"
proof -
  have "M(⋃x∈A. B(x))" using assms family_union_closed Pi_assumptions B_replacement by simp
  then
  obtain r where "well_ord(⋃x∈A. B(x),r)" "M(r)"
    using choice_ax_well_ord by blast
  let ?f="λx∈A. minimum(r,B(x))"
  have "M(minimum(r, B(x)))" if "x∈A" for x
  proof -
    from ‹well_ord(_,r)› ‹x∈A›
    have "well_ord(B(x),r)" using well_ord_subset UN_upper by simp
    with assms ‹x∈A› ‹M(r)›
    show ?thesis using Pi_assumptions by blast
  qed
  with assms and ‹M(r)›
  have "M(?f)"
    using Pi_assumptions minimum_replacement lam_closed
    by simp
  moreover from assms and calculation
  have "?f ∈ Pi⇗M⇖(A,B)"
    using lam_type[OF minimum_in, OF ‹well_ord(⋃x∈A. B(x),r)›, of A B]
      Pi_rel_char by auto
  ultimately
  show ?thesis by blast
qed

lemma AC_Pi_rel: assumes "⋀x. x ∈ A ⟹ ∃y. y ∈ B(x)"
  shows "∃z[M]. z ∈ Pi⇗M⇖(A, B)"
proof (cases "A=0")
  interpret Pi0:M_Pi_assumptions_0
    using Pi_assumptions by unfold_locales auto
  case True
  then
  show ?thesis using assms by simp
next
  case False
  then
  obtain a where "a ∈ A" by auto
      ― ‹It is noteworthy that without obtaining an element of
        term‹A›, the final step won't work›
  with assms
  show ?thesis by (blast intro!: AC_M)
qed

end ― ‹locale‹M_Pi_assumptions_choice››


context M_cardinal_AC
begin

subsection‹Strengthened Forms of Existing Theorems on Cardinals›

lemma cardinal_rel_eqpoll_rel: "M(A) ⟹ |A|⇗M⇖ ≈⇗M⇖ A"
  apply (rule choice_ax_well_ord [THEN rexE])
   apply (auto intro:well_ord_cardinal_rel_eqpoll_rel)
  done

lemmas cardinal_rel_idem = cardinal_rel_eqpoll_rel [THEN cardinal_rel_cong, simp]

lemma cardinal_rel_eqE: "|X|⇗M⇖ = |Y|⇗M⇖ ==> M(X) ⟹ M(Y) ⟹ X ≈⇗M⇖ Y"
  apply (rule choice_ax_well_ord [THEN rexE], assumption)
  apply (rule choice_ax_well_ord [THEN rexE, of Y], assumption)
  apply (rule well_ord_cardinal_rel_eqE, assumption+)
  done

lemma cardinal_rel_eqpoll_rel_iff: "M(X) ⟹ M(Y) ⟹ |X|⇗M⇖ = |Y|⇗M⇖ ⟷ X ≈⇗M⇖ Y"
  by (blast intro: cardinal_rel_cong cardinal_rel_eqE)

lemma cardinal_rel_disjoint_Un:
  "[| |A|⇗M⇖=|B|⇗M⇖;  |C|⇗M⇖=|D|⇗M⇖;  A ∩ C = 0;  B ∩ D = 0; M(A); M(B); M(C); M(D)|]
      ==> |A ∪ C|⇗M⇖ = |B ∪ D|⇗M⇖"
  by (simp add: cardinal_rel_eqpoll_rel_iff eqpoll_rel_disjoint_Un)

lemma lepoll_rel_imp_cardinal_rel_le: "A ≲⇗M⇖ B ==> M(A) ⟹ M(B) ⟹ |A|⇗M⇖ ≤ |B|⇗M⇖"
  apply (rule choice_ax_well_ord [THEN rexE]) prefer 2
   apply (erule well_ord_lepoll_rel_imp_cardinal_rel_le, assumption+)
  done

lemma cadd_rel_assoc: "⟦M(i); M(j); M(k)⟧ ⟹ (i ⊕⇗M⇖ j) ⊕⇗M⇖ k = i ⊕⇗M⇖ (j ⊕⇗M⇖ k)"
  apply (rule choice_ax_well_ord [THEN rexE]) prefer 2
   apply (rule choice_ax_well_ord [THEN rexE]) prefer 2
    apply (rule choice_ax_well_ord [THEN rexE]) prefer 2
     apply (rule well_ord_cadd_rel_assoc, assumption+)
  done

lemma cmult_rel_assoc: "⟦M(i); M(j); M(k)⟧ ⟹ (i ⊗⇗M⇖ j) ⊗⇗M⇖ k = i ⊗⇗M⇖ (j ⊗⇗M⇖ k)"
  apply (rule choice_ax_well_ord [THEN rexE]) prefer 2
   apply (rule choice_ax_well_ord [THEN rexE]) prefer 2
    apply (rule choice_ax_well_ord [THEN rexE]) prefer 2
     apply (rule well_ord_cmult_rel_assoc, assumption+)
  done

lemma cadd_cmult_distrib: "⟦M(i); M(j); M(k)⟧ ⟹ (i ⊕⇗M⇖ j) ⊗⇗M⇖ k = (i ⊗⇗M⇖ k) ⊕⇗M⇖ (j ⊗⇗M⇖ k)"
  apply (rule choice_ax_well_ord [THEN rexE]) prefer 2
   apply (rule choice_ax_well_ord [THEN rexE]) prefer 2
    apply (rule choice_ax_well_ord [THEN rexE]) prefer 2
     apply (rule well_ord_cadd_cmult_distrib, assumption+)
  done


lemma InfCard_rel_square_eq: "InfCard⇗M⇖(|A|⇗M⇖) ⟹ M(A) ⟹ A×A ≈⇗M⇖ A"
  apply (rule choice_ax_well_ord [THEN rexE]) prefer 2
   apply (erule well_ord_InfCard_rel_square_eq, assumption, simp_all)
  done

subsection ‹The relationship between cardinality and le-pollence›

lemma Card_rel_le_imp_lepoll_rel:
  assumes "|A|⇗M⇖ ≤ |B|⇗M⇖"
    and types: "M(A)" "M(B)"
  shows "A ≲⇗M⇖ B"
proof -
  have "A ≈⇗M⇖ |A|⇗M⇖"
    by (rule cardinal_rel_eqpoll_rel [THEN eqpoll_rel_sym], simp_all add:types)
  also have "... ≲⇗M⇖ |B|⇗M⇖"
    by (rule le_imp_subset [THEN subset_imp_lepoll_rel]) (rule assms, simp_all add:types)
  also have "... ≈⇗M⇖ B"
    by (rule cardinal_rel_eqpoll_rel, simp_all add:types)
  finally show ?thesis by (simp_all add:types)
qed

lemma le_Card_rel_iff: "Card⇗M⇖(K) ==> M(K) ⟹ M(A) ⟹ |A|⇗M⇖ ≤ K ⟷ A ≲⇗M⇖ K"
  apply (erule Card_rel_cardinal_rel_eq [THEN subst], assumption, rule iffI,
      erule Card_rel_le_imp_lepoll_rel, assumption+)
  apply (erule lepoll_rel_imp_cardinal_rel_le, assumption+)
  done

lemma cardinal_rel_0_iff_0 [simp]: "M(A) ⟹ |A|⇗M⇖ = 0 ⟷ A = 0"
  using cardinal_rel_0 eqpoll_rel_0_iff [THEN iffD1]
    cardinal_rel_eqpoll_rel_iff [THEN iffD1, OF _ nonempty]
  by auto

lemma cardinal_rel_lt_iff_lesspoll_rel:
  assumes i: "Ord(i)" and
    types: "M(i)" "M(A)"
  shows "i < |A|⇗M⇖ ⟷ i ≺⇗M⇖ A"
proof
  assume "i < |A|⇗M⇖"
  hence  "i ≺⇗M⇖ |A|⇗M⇖"
    by (blast intro: lt_Card_rel_imp_lesspoll_rel types)
  also have "...  ≈⇗M⇖ A"
    by (rule cardinal_rel_eqpoll_rel) (simp_all add:types)
  finally show "i ≺⇗M⇖ A" by (simp_all add:types)
next
  assume "i ≺⇗M⇖ A"
  also have "...  ≈⇗M⇖ |A|⇗M⇖"
    by (blast intro: cardinal_rel_eqpoll_rel eqpoll_rel_sym types)
  finally have "i ≺⇗M⇖ |A|⇗M⇖" by (simp_all add:types)
  thus  "i < |A|⇗M⇖" using i types
    by (force intro: cardinal_rel_lt_imp_lt lesspoll_rel_cardinal_rel_lt)
qed

lemma cardinal_rel_le_imp_lepoll_rel: " i ≤ |A|⇗M⇖ ==> M(i) ⟹ M(A) ⟹i ≲⇗M⇖ A"
  by (blast intro: lt_Ord Card_rel_le_imp_lepoll_rel Ord_cardinal_rel_le le_trans)


subsection‹Other Applications of AC›

text‹We have an example of instantiating a locale involving higher
order variables inside a proof, by using the assumptions of the
first order, active locale.›

lemma surj_rel_implies_inj_rel:
  assumes f: "f ∈ surj⇗M⇖(X,Y)" and
    types: "M(f)" "M(X)" "M(Y)"
  shows "∃g[M]. g ∈ inj⇗M⇖(Y,X)"
proof -
  from types
  interpret M_Pi_assumptions_choice _ Y "λy. f-``{y}"
    by unfold_locales (auto intro:surj_imp_inj_replacement dest:transM)
  from f AC_Pi_rel
  obtain z where z: "z ∈ Pi⇗M⇖(Y, λy. f -`` {y})"
    ― ‹In this and the following ported result, it is not clear how
        uniformly are "\_char" theorems to be used›
    using surj_rel_char
    by (auto simp add: surj_def types) (fast dest: apply_Pair)
  show ?thesis
  proof
    show "z ∈ inj⇗M⇖(Y, X)" "M(z)"
      using z surj_is_fun[of f X Y] f Pi_rel_char
      by (auto dest: apply_type Pi_memberD
          intro: apply_equality Pi_type f_imp_injective
          simp add:types mem_surj_abs)
  qed
qed


text‹Kunen's Lemma 10.20›
lemma surj_rel_implies_cardinal_rel_le:
  assumes f: "f ∈ surj⇗M⇖(X,Y)" and
    types:"M(f)" "M(X)" "M(Y)"
  shows "|Y|⇗M⇖ ≤ |X|⇗M⇖"
proof (rule lepoll_rel_imp_cardinal_rel_le)
  from f [THEN surj_rel_implies_inj_rel]
  obtain g where "g ∈ inj⇗M⇖(Y,X)"
    by (blast intro:types)
  then
  show "Y ≲⇗M⇖ X"
    using inj_rel_char
    by (auto simp add: def_lepoll_rel types)
qed (simp_all add:types)

end ― ‹locale‹M_cardinal_AC››

text‹The set-theoretic universe.›

abbreviation
  Universe :: "i⇒o" (‹𝒱›) where
  "𝒱(x) ≡ True"

lemma separation_absolute: "separation(𝒱, P)"
  unfolding separation_def
  by (rule rallI, rule_tac x="{x∈_ . P(x)}" in rexI) auto

lemma univalent_absolute:
  assumes "univalent(𝒱, A, P)" "P(x, b)" "x ∈ A"
  shows "P(x, y) ⟹ y = b"
  using assms
  unfolding univalent_def by force

lemma replacement_absolute: "strong_replacement(𝒱, P)"
  unfolding strong_replacement_def
proof (intro rallI impI)
  fix A
  assume "univalent(𝒱, A, P)"
  then
  show "∃Y[𝒱]. ∀b[𝒱]. b ∈ Y ⟷ (∃x[𝒱]. x ∈ A ∧ P(x, b))"
    by (rule_tac x="{y. x∈A , P(x,y)}" in rexI)
      (auto dest:univalent_absolute[of _ P])
qed

lemma Union_ax_absolute: "Union_ax(𝒱)"
  unfolding Union_ax_def big_union_def
  by (auto intro:rexI[of _ "⋃_"])

lemma upair_ax_absolute: "upair_ax(𝒱)"
  unfolding upair_ax_def upair_def rall_def rex_def
  by (auto)

lemma power_ax_absolute:"power_ax(𝒱)"
proof -
  {
    fix x
    have "∀y[𝒱]. y ∈ Pow(x) ⟷ (∀z[𝒱]. z ∈ y ⟶ z ∈ x)"
      by auto
  }
  then
  show "power_ax(𝒱)"
    unfolding power_ax_def powerset_def subset_def by blast
qed

locale M_cardinal_UN =  M_Pi_assumptions_choice _ K X for K X +
  assumes
    ― ‹The next assumption is required by @{thm Least_closed}›
    X_witness_in_M: "w ∈ X(x) ⟹ M(x)"
    and
    lam_m_replacement:"M(f) ⟹ strong_replacement(M,
      λx y. y = ⟨x, μ i. x ∈ X(i), f ` (μ i. x ∈ X(i)) ` x⟩)"
    and
    inj_replacement:
    "M(x) ⟹ strong_replacement(M, λy z. y ∈ inj⇗M⇖(X(x), K) ∧ z = {⟨x, y⟩})"
    "strong_replacement(M, λx y. y = inj⇗M⇖(X(x), K))"
    "strong_replacement(M,
      λx z. z = Sigfun(x, λi. inj⇗M⇖(X(i), K)))"
    "M(r) ⟹ strong_replacement(M,
      λx y. y = ⟨x, minimum(r, inj⇗M⇖(X(x), K))⟩)"

begin

lemma UN_closed: "M(⋃i∈K. X(i))"
  using family_union_closed B_replacement Pi_assumptions by simp

text‹Kunen's Lemma 10.21›
lemma cardinal_rel_UN_le:
  assumes K: "InfCard⇗M⇖(K)"
  shows "(⋀i. i∈K ⟹ |X(i)|⇗M⇖ ≤ K) ⟹ |⋃i∈K. X(i)|⇗M⇖ ≤ K"
proof (simp add: K InfCard_rel_is_Card_rel le_Card_rel_iff Pi_assumptions)
  have "M(f) ⟹ M(λx∈(⋃x∈K. X(x)). ⟨μ i. x ∈ X(i), f ` (μ i. x ∈ X(i)) ` x⟩)" for f
    using lam_m_replacement X_witness_in_M Least_closed' Pi_assumptions UN_closed
    by (rule_tac lam_closed) (auto dest:transM)
  note types = this Pi_assumptions UN_closed
  have [intro]: "Ord(K)" by (blast intro: InfCard_rel_is_Card_rel
        Card_rel_is_Ord K types)
  interpret pii:M_Pi_assumptions_choice _ K "λi. inj⇗M⇖(X(i), K)"
    using inj_replacement Pi_assumptions transM[of _ K]
    by unfold_locales (simp_all del:mem_inj_abs)
  assume asm:"⋀i. i∈K ⟹ X(i) ≲⇗M⇖ K"
  then
  have "⋀i. i∈K ⟹ M(inj⇗M⇖(X(i), K))"
    by (auto simp add: types)
  interpret V:M_N_Perm M "𝒱"
    using separation_absolute replacement_absolute Union_ax_absolute
      power_ax_absolute upair_ax_absolute
    by unfold_locales auto
  note bad_simps[simp del] = V.N.Forall_in_M_iff V.N.Equal_in_M_iff
    V.N.nonempty
  have abs:"inj_rel(𝒱,x,y) = inj(x,y)" for x y
    using V.N.inj_rel_char by simp
  from asm
  have "⋀i. i∈K ⟹ ∃f[M]. f ∈ inj⇗M⇖(X(i), K)"
    by (simp add: types def_lepoll_rel)
  then
  obtain f where "f ∈ (∏i∈K. inj⇗M⇖(X(i), K))" "M(f)"
    using pii.AC_Pi_rel pii.Pi_rel_char by auto
  with abs
  have f:"f ∈ (∏i∈K. inj(X(i), K))"
    using Pi_weaken_type[OF _ V.inj_rel_transfer, of f K X "λ_. K"]
      Pi_assumptions by simp
  { fix z
    assume z: "z ∈ (⋃i∈K. X(i))"
    then obtain i where i: "i ∈ K" "Ord(i)" "z ∈ X(i)"
      by (blast intro: Ord_in_Ord [of K])
    hence "(μ i. z ∈ X(i)) ≤ i" by (fast intro: Least_le)
    hence "(μ i. z ∈ X(i)) < K" by (best intro: lt_trans1 ltI i)
    hence "(μ i. z ∈ X(i)) ∈ K" and "z ∈ X(μ i. z ∈ X(i))"
      by (auto intro: LeastI ltD i)
  } note mems = this
  have "(⋃i∈K. X(i)) ≲⇗M⇖ K × K"
  proof (simp add:types def_lepoll_rel)
    show "∃f[M]. f ∈ inj(⋃x∈K. X(x), K × K)"
      apply (rule rexI)
       apply (rule_tac c = "λz. ⟨μ i. z ∈ X(i), f ` (μ i. z ∈ X(i)) ` z⟩"
          and d = "λ⟨i,j⟩. converse (f`i) ` j" in lam_injective)
        apply (force intro: f inj_is_fun mems apply_type Perm.left_inverse)+
      apply (simp add:types ‹M(f)›)
      done
  qed
  also have "... ≈⇗M⇖ K"
    by (simp add: K InfCard_rel_square_eq InfCard_rel_is_Card_rel
        Card_rel_cardinal_rel_eq types)
  finally have "(⋃i∈K. X(i)) ≲⇗M⇖ K" by (simp_all add:types)
  then
  show ?thesis
    by (simp add: K InfCard_rel_is_Card_rel le_Card_rel_iff types)
qed

end ― ‹locale‹M_cardinal_UN››

end

Theory FiniteFun_Relative

section‹Relativization of Finite Functions›
theory FiniteFun_Relative
  imports
    Lambda_Replacement
begin

lemma FiniteFunI :
  assumes  "f∈Fin(A×B)" "function(f)"
  shows "f ∈ A -||> B"
  using assms
proof(induct)
  case 0
  then show ?case using emptyI by simp
next
  case (cons p f)
  moreover
  from assms this
  have "fst(p)∈A" "snd(p)∈B" "function(f)"
    using snd_type[OF ‹p∈_›] function_subset
    by auto
  moreover
  from ‹function(cons(p,f))› ‹p∉f› ‹p∈_›
  have "fst(p)∉domain(f)"
    unfolding function_def
    by force
  ultimately
  show ?case
    using consI[of "fst(p)" _ "snd(p)"]
    by auto
qed

subsection‹The set of finite binary sequences›

text‹We implement the poset for adding one Cohen real, the set
$2^{<\omega}$ of finite binary sequences.›

definition
  seqspace :: "[i,i] ⇒ i" (‹_⇗<_⇖› [100,1]100) where
  "B⇗<α⇖ ≡ ⋃n∈α. (n→B)"

schematic_goal seqspace_fm_auto:
  assumes
    "i ∈ nat" "j ∈ nat" "h∈nat" "env ∈ list(A)"
  shows
    "(∃om∈A. omega(##A,om) ∧ nth(i,env) ∈ om ∧ is_funspace(##A, nth(i,env), nth(h,env), nth(j,env))) ⟷ (A, env ⊨ (?sqsprp(i,j,h)))"
  unfolding is_funspace_def
  by (insert assms ; (rule iff_sats | simp)+)

synthesize "seqspace_rel" from_schematic "seqspace_fm_auto"
arity_theorem for "seqspace_rel_fm"

lemma seqspaceI[intro]: "n∈α ⟹ f:n→B ⟹ f∈B⇗<α⇖"
  unfolding seqspace_def by blast

lemma seqspaceD[dest]: "f∈B⇗<α⇖ ⟹ ∃n∈α. f:n→B"
  unfolding seqspace_def by blast

locale M_seqspace =  M_trancl + M_replacement +
  assumes
    seqspace_replacement: "M(B) ⟹ strong_replacement(M,λn z. n∈nat ∧ is_funspace(M,n,B,z))"
begin

lemma seqspace_closed:
  "M(B) ⟹ M(B⇗<ω⇖)"
  unfolding seqspace_def using seqspace_replacement[of B] RepFun_closed2
  by simp
end

subsection‹Representation of finite functions›

text‹A function $f\in A\to_{\mathit{fin}}B$ can be represented by a function
$g\in |f| \to A\times B$. It is clear that $f$ can be represented by
any $g' = g \cdot \pi$, where $\pi$ is a permutation $\pi\in dom(g)\to dom(g)$.
We use this representation of $A\to_{\mathit{fin}}B$ to prove that our model is
closed under $\_\to_{\mathit{fin}}\_$.›

text‹A function $g\in n\to A\times B$ that is functional in the first components.›
definition cons_like :: "i ⇒ o" where
  "cons_like(f) ≡ ∀ i∈domain(f) . ∀j∈i . fst(f`i) ≠ fst(f`j)"

relativize "cons_like" "cons_like_rel"

lemma (in M_seqspace) cons_like_abs:
  "M(f) ⟹ cons_like(f) ⟷ cons_like_rel(M,f)"
  unfolding cons_like_def cons_like_rel_def
  using fst_abs
  by simp

definition FiniteFun_iso :: "[i,i,i,i,i] ⇒ o" where
  "FiniteFun_iso(A,B,n,g,f) ≡  (∀ i∈n . g`i ∈ f) ∧ (∀ ab∈f. (∃ i∈n. g`i=ab))"

text‹From a function $g\in n \to A\times B$ we obtain a finite function in term‹A-||>B›.›

definition to_FiniteFun :: "i ⇒ i" where
  "to_FiniteFun(f) ≡ {f`i. i∈domain(f)}"

definition FiniteFun_Repr :: "[i,i] ⇒ i" where
  "FiniteFun_Repr(A,B) ≡ {f ∈ (A×B)⇗<ω⇖ . cons_like(f) }"

locale M_FiniteFun =  M_seqspace +
  assumes
    cons_like_separation : "separation(M,λf. cons_like_rel(M,f))"
    and
    separation_is_function : "separation(M, is_function(M))"
begin

lemma supset_separation: "separation(M, λ x. ∃a. ∃b. x = ⟨a,b⟩ ∧ b ⊆ a)"
  using separation_pair separation_subset lam_replacement_fst lam_replacement_snd
  by simp

lemma to_finiteFun_replacement: "strong_replacement(M, λx y. y = range(x))"
  using lam_replacement_range lam_replacement_imp_strong_replacement
  by simp

lemma fun_range_eq: "f∈A→B ⟹ {f`i . i∈domain(f) } = range(f)"
  using ZF_Library.range_eq_image[of f] domain_of_fun image_fun func.apply_rangeI
  by simp

lemma FiniteFun_fst_type:
  assumes "h∈A-||>B" "p∈h"
  shows  "fst(p)∈domain(h)"
  using assms
  by(induct h, auto)

lemma FinFun_closed:
  "M(A) ⟹ M(B) ⟹ M(⋃{n→A×B . n∈ω})"
  using cartprod_closed seqspace_closed
  unfolding seqspace_def by simp

lemma cons_like_lt :
  assumes "n∈ω" "f∈succ(n)→A×B" "cons_like(f)"
  shows "restrict(f,n)∈n→A×B" "cons_like(restrict(f,n))"
  using assms
proof (auto simp add: le_imp_subset restrict_type2)
  from ‹f∈_›
  have D:"domain(restrict(f,n)) = n" "domain(f) = succ(n)"
    using domain_of_fun domain_restrict by auto
  {
    fix i j
    assume "i∈domain(restrict(f,n))" (is "i∈?D") "j∈i"
    with ‹n∈_› D
    have "j∈?D" "i∈n" "j∈n" using Ord_trans[of j] by simp_all
    with D ‹cons_like(f)›  ‹j∈n› ‹i∈n› ‹j∈i›
    have "fst(restrict(f,n)`i) ≠ fst(restrict(f,n)`j)"
      using restrict_if unfolding cons_like_def by auto
  }
  then show "cons_like(restrict(f,n))"
    unfolding cons_like_def by auto
qed

text‹A finite function term‹f ∈ A -||> B› can be represented by a
function $g \in n \to A \times B$, with $n=|f|$.›
lemma FiniteFun_iso_intro1:
  assumes "f ∈ (A -||> B)"
  shows "∃n∈ω . ∃g∈n→A×B. FiniteFun_iso(A,B,n,g,f) ∧ cons_like(g)"
  using assms
proof(induct f,force simp add:emptyI FiniteFun_iso_def cons_like_def)
  case (consI a b h)
  then obtain n g where
    HI: "n∈ω" "g∈n→A×B" "FiniteFun_iso(A,B,n,g,h)" "cons_like(g)" by auto
  let ?G="λ i ∈ succ(n) . if i=n then <a,b> else g`i"
  from HI ‹a∈_› ‹b∈_›
  have G: "?G ∈ succ(n)→A×B"
    by (auto intro:lam_type)
  have "FiniteFun_iso(A,B,succ(n),?G,cons(<a,b>,h))"
    unfolding FiniteFun_iso_def
  proof(intro conjI)
    {
      fix i
      assume "i∈succ(n)"
      then consider "i=n" | "i∈n∧i≠n" by auto
      then have "?G ` i ∈ cons(<a,b>,h)"
        using HI
        by(cases,simp;auto simp add:HI FiniteFun_iso_def)
    }
    then show "∀i∈succ(n). ?G ` i ∈ cons(⟨a, b⟩, h)" ..
  next
    { fix ab'
      assume "ab' ∈ cons(<a,b>,h)"
      then
      consider  "ab' = <a,b>" | "ab' ∈ h" using cons_iff by auto
      then
      have "∃i ∈ succ(n) . ?G`i = ab'" unfolding FiniteFun_iso_def
      proof(cases,simp)
        case 2
        with HI obtain i
          where "i∈n" "g`i=ab'" unfolding FiniteFun_iso_def by auto
        with HI show ?thesis using  ltI[OF ‹i∈_›] by auto
      qed
    }
    then
    show "∀ab∈cons(⟨a, b⟩, h). ∃i∈succ(n). ?G`i = ab"  ..
  qed
  with HI G
  have 1: "?G∈succ(n)→A×B" "FiniteFun_iso(A,B,succ(n),?G,cons(<a,b>,h))" "succ(n)∈ω" by simp_all
  have "cons_like(?G)"
  proof -
    from ‹?G∈_› ‹g∈_›
    have "domain(g) = n" using domain_of_fun by simp
    {
      fix i j
      assume "i∈domain(?G)" "j∈i"
      with ‹n∈_›
      have "j∈n" using Ord_trans[of j _ n] by auto
      from ‹i∈_› consider (a) "i=n ∧ i∉n" | (b) "i∈n" by auto
      then
      have " fst(?G`i) ≠ fst(?G`j)"
      proof(cases)
        case a
        with ‹j∈n› HI
        have "?G`i=<a,b>" "?G`j=g`j" "g`j∈h"
          unfolding FiniteFun_iso_def by auto
        with ‹a∉_› ‹h∈_›
        show ?thesis using  FiniteFun_fst_type by auto
      next
        case b
        with ‹i∈n› ‹j∈i› ‹j∈n› HI ‹domain(g) = n›
        show ?thesis unfolding cons_like_def
          using mem_not_refl by auto
      qed
    }
    then show ?thesis unfolding cons_like_def by auto
  qed
  with 1 show ?case by auto
qed

text‹All the representations of term‹f∈A-||>B› are equal.›
lemma FiniteFun_isoD :
  assumes "n∈ω" "g∈n→A×B" "f∈A-||>B" "FiniteFun_iso(A,B,n,g,f)"
  shows "to_FiniteFun(g) = f"
proof
  show "to_FiniteFun(g) ⊆ f"
  proof
    fix ab
    assume "ab∈to_FiniteFun(g)"
    moreover
    note assms
    moreover from calculation
    obtain i where "i∈n" "g`i=ab" "ab∈A×B"
      unfolding to_FiniteFun_def using domain_of_fun by auto
    ultimately
    show "ab∈f" unfolding FiniteFun_iso_def by auto
  qed
next
  show "f ⊆ to_FiniteFun(g)"
  proof
    fix ab
    assume "ab∈f"
    with assms
    obtain i where "i∈n" "g`i=ab" "ab∈A×B"
      unfolding FiniteFun_iso_def by auto
    with assms
    show "ab ∈ to_FiniteFun(g)"
      unfolding to_FiniteFun_def
      using domain_of_fun by auto
  qed
qed

lemma to_FiniteFun_succ_eq :
  assumes "n∈ω" "f∈succ(n) → A"
  shows "to_FiniteFun(f) = cons(f`n,to_FiniteFun(restrict(f,n)))"
  using assms domain_restrict domain_of_fun
  unfolding to_FiniteFun_def by auto

text‹If $g \in n\to A\times B$ is term‹cons_like›, then it is a representation of
term‹to_FiniteFun(g)›.›
lemma FiniteFun_iso_intro_to:
  assumes "n∈ω" "g∈n→A×B" "cons_like(g)"
  shows "to_FiniteFun(g) ∈ (A -||> B) ∧ FiniteFun_iso(A,B,n,g,to_FiniteFun(g))"
  using assms
proof(induct n  arbitrary:g rule:nat_induct)
  case 0
  fix g
  assume "g∈0→A×B"
  then
  have "g=0" by simp
  then have "to_FiniteFun(g)=0" unfolding to_FiniteFun_def by simp
  then show "to_FiniteFun(g) ∈ (A -||> B) ∧ FiniteFun_iso(A,B,0,g,to_FiniteFun(g))"
    using emptyI unfolding FiniteFun_iso_def by simp
next
  case (succ x)
  fix g
  let ?g'="restrict(g,x)"
  assume "g∈succ(x)→A×B" "cons_like(g)"
  with succ.hyps ‹g∈_›
  have "cons_like(?g')" "?g' ∈ x→A×B" "g`x∈A×B" "domain(g) = succ(x)"
    using cons_like_lt succI1 apply_funtype domain_of_fun by simp_all
  with succ.hyps  ‹?g'∈_› ‹x∈ω›
  have HI:
    "to_FiniteFun(?g') ∈ A -||> B" (is "(?h) ∈ _")
    "FiniteFun_iso(A,B,x,?g',to_FiniteFun(?g'))"
    by simp_all
  then
  have "fst(g`x) ∉ domain(?h)"
  proof -
    {
      assume "fst(g`x) ∈ domain(?h)"
      with HI ‹x∈_›
      obtain i b
        where "i∈x" "<fst(?g'`i),b>∈?h" "i<x" "fst(g`x) = fst(?g'`i)"
        unfolding FiniteFun_iso_def using ltI by auto
      with ‹cons_like(g)› ‹domain(g) = _›
      have False
        unfolding cons_like_def by auto
    }
    then show ?thesis ..
  qed
  with HI assms ‹g`x∈_›
  have "cons(g`x,?h) ∈ A-||>B" (is "?h' ∈_") using consI by auto
  have "FiniteFun_iso(A,B,succ(x),g,?h')"
    unfolding FiniteFun_iso_def
  proof
    { fix i
      assume "i∈succ(x)"
      with ‹x∈_› consider (a) "i=x"| (b) "i∈x∧i≠x" by auto
      then have "g`i∈ ?h'"
      proof(cases,simp)
        case b
        with ‹FiniteFun_iso(_,_,_,?g',?h)›
        show ?thesis unfolding FiniteFun_iso_def by simp
      qed
    }
    then show "∀i∈succ(x). g ` i ∈ cons(g ` x, ?h)" ..
  next
    {
      fix ab
      assume "ab∈?h'"
      then consider "ab=g`x" | "ab ∈ ?h" using cons_iff by auto
      then
      have "∃i ∈ succ(x) . g`i = ab" unfolding FiniteFun_iso_def
      proof(cases,simp)
        case 2
        with HI obtain i
          where 2:"i∈x" "?g'`i=ab"  unfolding FiniteFun_iso_def by auto
        with ‹x∈_›
        have "i≠x" "i∈succ(x)" using  ltI[OF ‹i∈_›] by auto
        with 2 HI show ?thesis by auto
      qed
    } then show "∀ab∈cons(g ` x, ?h). ∃i∈succ(x). g ` i = ab" ..
  qed
  with ‹?h'∈_›
  show "to_FiniteFun(g) ∈ A -||>B ∧ FiniteFun_iso(A,B,succ(x),g,to_FiniteFun(g))"
    using to_FiniteFun_succ_eq[OF ‹x∈_› ‹g∈_›,symmetric] by auto
qed

lemma FiniteFun_iso_intro2:
  assumes "n∈ω" "f∈n→A×B" "cons_like(f)"
  shows "∃ g ∈ (A -||> B) . FiniteFun_iso(A,B,n,f,g)"
  using assms FiniteFun_iso_intro_to by blast

lemma FiniteFun_eq_range_Repr :
  shows "{range(h) . h ∈ FiniteFun_Repr(A,B) } = {to_FiniteFun(h) . h ∈ FiniteFun_Repr(A,B) }"
  unfolding FiniteFun_Repr_def to_FiniteFun_def seqspace_def
  using fun_range_eq
  by(intro equalityI subsetI,auto)


lemma FiniteFun_eq_to_FiniteFun_Repr :
  shows "A-||>B = {to_FiniteFun(h) . h ∈ FiniteFun_Repr(A,B) } "
    (is "?Y=?X")
proof
  {
    fix f
    assume "f∈A-||>B"
    then obtain n g where
      1: "n∈ω" "g∈n→A×B" "FiniteFun_iso(A,B,n,g,f)" "cons_like(g)"
      using FiniteFun_iso_intro1 by blast
    with ‹f∈_›
    have "cons_like(g)" "f=to_FiniteFun(g)" "domain(g) = n" "g∈FiniteFun_Repr(A,B)"
      using FiniteFun_isoD domain_of_fun
      unfolding FiniteFun_Repr_def
      by auto
    with 1 have "f∈?X"
      by auto
  } then show "?Y⊆?X" ..
next
  {
    fix f
    assume "f∈?X"
    then obtain g where
      A:"g∈FiniteFun_Repr(A,B)" "f=to_FiniteFun(g)" "cons_like(g)"
      using RepFun_iff unfolding FiniteFun_Repr_def by auto
    then obtain n where "n∈ω" "g∈n→A×B" "domain(g) = n"
      unfolding FiniteFun_Repr_def using domain_of_fun by force
    with A
    have "f∈?Y"
      using FiniteFun_iso_intro_to by simp
  } then show "?X⊆?Y" ..
qed

lemma FiniteFun_Repr_closed :
  assumes "M(A)" "M(B)"
  shows "M(FiniteFun_Repr(A,B))"
  unfolding FiniteFun_Repr_def
  using assms cartprod_closed
    seqspace_closed separation_closed cons_like_abs cons_like_separation
  by simp

lemma to_FiniteFun_closed:
  assumes "M(A)" "f∈A"
  shows "M(range(f))"
  using assms transM[of _ A] by simp

lemma To_FiniteFun_Repr_closed :
  assumes "M(A)" "M(B)"
  shows "M({range(h) . h ∈ FiniteFun_Repr(A,B) })"
  using assms FiniteFun_Repr_closed
    RepFun_closed  to_finiteFun_replacement
    to_FiniteFun_closed[OF FiniteFun_Repr_closed]
  by simp

lemma FiniteFun_closed[intro,simp] :
  assumes "M(A)" "M(B)"
  shows "M(A -||> B)"
  using assms To_FiniteFun_Repr_closed FiniteFun_eq_to_FiniteFun_Repr
    FiniteFun_eq_range_Repr
  by simp

end ― ‹locale‹M_FiniteFun››

end
>

Theory ZF_Library_Relative

section‹Library of basic $\mathit{ZF}$ results\label{sec:zf-lib}›

theory ZF_Library_Relative
  imports
    Aleph_Relative― ‹must be before Cardinal\_AC\_Relative!›
    Cardinal_AC_Relative
    FiniteFun_Relative
begin

no_notation sum (infixr ‹+› 65)
notation oadd (infixl ‹+› 65)

lemma (in M_cardinal_arith_jump) csucc_rel_cardinal_rel:
  assumes "Ord(κ)" "M(κ)"
  shows "(|κ|⇗M⇖+)⇗M⇖ = (κ+)⇗M⇖"
proof (intro le_anti_sym)― ‹show both inequalities›
  from assms
  have hips:"M((κ+)⇗M⇖)" "Ord((κ+)⇗M⇖)" "κ < (κ+)⇗M⇖"
    using Card_rel_csucc_rel[THEN Card_rel_is_Ord]
      csucc_rel_basic by simp_all
  then
  show "(|κ|⇗M⇖+)⇗M⇖ ≤ (κ+)⇗M⇖"
    using Ord_cardinal_rel_le[THEN lt_trans1]
      Card_rel_csucc_rel
    unfolding csucc_rel_def
    by (rule_tac Least_antitone) (assumption, simp_all add:assms)
  from assms
  have "κ < L" if "Card⇗M⇖(L)" "|κ|⇗M⇖ < L" "M(L)" for L
    using (* Card_rel_le_iff[THEN iffD1, THEN le_trans, of κ _ L] *) that
      Card_rel_is_Ord leI Card_rel_le_iff[of κ L]
    by (rule_tac ccontr, auto dest:not_lt_imp_le) (fast dest: le_imp_not_lt)
  with hips
  show "(κ+)⇗M⇖ ≤ (|κ|⇗M⇖+)⇗M⇖"
    using Ord_cardinal_rel_le[THEN lt_trans1] Card_rel_csucc_rel
    unfolding csucc_rel_def
    by (rule_tac Least_antitone) (assumption, auto simp add:assms)
qed

lemma (in M_cardinal_arith_jump) csucc_rel_le_mono:
  assumes "κ ≤ ν" "M(κ)" "M(ν)"
  shows "(κ+)⇗M⇖ ≤ (ν+)⇗M⇖"
proof (cases "κ = ν")
  case True
  with assms
  show ?thesis using Card_rel_csucc_rel [THEN Card_rel_is_Ord] by simp
next
  case False
  with assms
  have "κ < ν" using le_neq_imp_lt by simp
  show ?thesis― ‹by way of contradiction›
  proof (rule ccontr)
    assume "¬ (κ+)⇗M⇖ ≤ (ν+)⇗M⇖"
    with assms
    have "(ν+)⇗M⇖ < (κ+)⇗M⇖"
      using Card_rel_csucc_rel[THEN Card_rel_is_Ord] le_Ord2 lt_Ord
      by (intro not_le_iff_lt[THEN iffD1]) auto
    with assms
    have "(ν+)⇗M⇖ ≤ |κ|⇗M⇖"
      using le_Ord2[THEN Card_rel_csucc_rel, of κ ν]
        Card_rel_lt_csucc_rel_iff[of "(ν+)⇗M⇖" "|κ|⇗M⇖", THEN iffD1]
        csucc_rel_cardinal_rel[OF lt_Ord] leI[of "(ν+)⇗M⇖" "(κ+)⇗M⇖"]
      by simp
    with assms
    have "(ν+)⇗M⇖ ≤ κ"
      using Ord_cardinal_rel_le[OF lt_Ord] le_trans by auto
    with assms
    have "ν < κ"
      using csucc_rel_basic le_Ord2[THEN Card_rel_csucc_rel, of κ ν] Card_rel_is_Ord
        le_Ord2
      by (rule_tac j="(ν+)⇗M⇖" in lt_trans2) simp_all
    with ‹κ < ν›
    show "False" using le_imp_not_lt leI by blast
  qed
qed

lemma (in M_cardinal_AC) cardinal_rel_succ_not_0:   "|A|⇗M⇖ = succ(n) ⟹ M(A) ⟹ M(n) ⟹ A ≠ 0"
  by auto

(* "Finite_to_one(X,Y) ≡ {f:X→Y. ∀y∈Y. Finite({x∈X . f`x = y})}" *)
reldb_add functional "Finite" "Finite" ― ‹wrongly done? Finite is absolute›
relativize functional "Finite_to_one" "Finite_to_one_rel" external
  (* reldb_add relational "Finite" "is_Finite" ― ‹don't have is_Finite yet›
relationalize "Finite_to_one_rel" "is_Finite_to_one" *)

notation Finite_to_one_rel (‹Finite'_to'_one⇗_⇖'(_,_')›)

abbreviation
  Finite_to_one_r_set :: "[i,i,i] ⇒ i" (‹Finite'_to'_one⇗_⇖'(_,_')›) where
  "Finite_to_one⇗M⇖(X,Y) ≡ Finite_to_one_rel(##M,X,Y)"

locale M_ZF_library =  M_cardinal_arith + M_aleph + M_FiniteFun + M_replacement_extra
begin

lemma Finite_Collect_imp: "Finite({x∈X . Q(x)}) ⟹ Finite({x∈X . M(x) ∧ Q(x)})"
  (is "Finite(?A) ⟹ Finite(?B)")
  using subset_Finite[of ?B ?A] by auto

lemma Finite_to_one_relI[intro]:
  assumes "f:X→⇗M⇖Y" "⋀y. y∈Y ⟹ Finite({x∈X . f`x = y})"
    and types:"M(f)" "M(X)" "M(Y)"
  shows "f ∈ Finite_to_one⇗M⇖(X,Y)"
  using assms Finite_Collect_imp unfolding Finite_to_one_rel_def
  by (simp)

lemma Finite_to_one_relI'[intro]:
  assumes "f:X→⇗M⇖Y" "⋀y. y∈Y ⟹ Finite({x∈X . M(x) ∧ f`x = y})"
    and types:"M(f)" "M(X)" "M(Y)"
  shows "f ∈ Finite_to_one⇗M⇖(X,Y)"
  using assms unfolding Finite_to_one_rel_def
  by (simp)

lemma Finite_to_one_relD[dest]:
  "f ∈ Finite_to_one⇗M⇖(X,Y) ⟹f:X→⇗M⇖Y"
  "f ∈ Finite_to_one⇗M⇖(X,Y) ⟹ y∈Y ⟹ M(Y) ⟹ Finite({x∈X . M(x) ∧ f`x = y})"
  unfolding Finite_to_one_rel_def by simp_all

lemma Diff_bij_rel:
  assumes "∀A∈F. X ⊆ A"
    and types: "M(F)" "M(X)" shows "(λA∈F. A-X) ∈ bij⇗M⇖(F, {A-X. A∈F})"
  using assms  def_inj_rel def_surj_rel unfolding bij_rel_def
  apply (auto)
   apply (subgoal_tac "M(λA∈F. A - X)" "M({A - X . A ∈ F})")
     apply (auto simp add:mem_function_space_rel_abs)
      apply (rule_tac lam_type, auto)
     prefer 4
     apply (subgoal_tac "M(λA∈F. A - X)" "M({A - X . A ∈ F})")
       apply(tactic ‹distinct_subgoals_tac›)
     apply (auto simp add:mem_function_space_rel_abs)
     apply (rule_tac lam_type, auto) prefer 3
    apply (subst subset_Diff_Un[of X])
     apply auto
proof -
  from types
  show "M({A - X . A ∈ F})"
    using diff_replacement
    by (rule_tac RepFun_closed) (auto dest:transM[of _ F])
  from types
  show "M(λA∈F. A - X)"
    using Pair_diff_replacement
    by (rule_tac lam_closed, auto dest:transM)
qed

lemma function_space_rel_nonempty:
  assumes "b∈B"  and types: "M(B)" "M(A)"
  shows "(λx∈A. b) : A →⇗M⇖ B"
proof -
  note assms
  moreover from this
  have "M(λx∈A. b)"
    using tag_replacement by (rule_tac lam_closed, auto dest:transM)
  ultimately
  show ?thesis
    by (simp add:mem_function_space_rel_abs)
qed

lemma mem_function_space_rel:
  assumes "f ∈ A →⇗M⇖ y" "M(A)" "M(y)"
  shows  "f ∈ A → y"
  using assms function_space_rel_char by simp

lemmas range_fun_rel_subset_codomain = range_fun_subset_codomain[OF mem_function_space_rel]

end ― ‹locale‹M_ZF_library››

context M_Pi_assumptions
begin

lemma mem_Pi_rel: "f ∈ Pi⇗M⇖(A,B) ⟹ f ∈ Pi(A, B)"
  using trans_closed mem_Pi_rel_abs
  by force

lemmas Pi_rel_rangeD = Pi_rangeD[OF mem_Pi_rel]

lemmas rel_apply_Pair = apply_Pair[OF mem_Pi_rel]

lemmas rel_apply_rangeI = apply_rangeI[OF mem_Pi_rel]

lemmas Pi_rel_range_eq = Pi_range_eq[OF mem_Pi_rel]

lemmas Pi_rel_vimage_subset = Pi_vimage_subset[OF mem_Pi_rel]

end ― ‹locale‹M_Pi_assumptions››

context M_ZF_library
begin

lemma mem_bij_rel: "⟦f ∈ bij⇗M⇖(A,B); M(A); M(B)⟧ ⟹ f∈bij(A,B)"
  using bij_rel_char by simp

lemma mem_inj_rel: "⟦f ∈ inj⇗M⇖(A,B); M(A); M(B)⟧ ⟹ f∈inj(A,B)"
  using inj_rel_char by simp

lemma mem_surj_rel: "⟦f ∈ surj⇗M⇖(A,B); M(A); M(B)⟧ ⟹ f∈surj(A,B)"
  using surj_rel_char by simp

lemmas rel_apply_in_range = apply_in_range[OF _ _ mem_function_space_rel]

lemmas rel_range_eq_image = ZF_Library.range_eq_image[OF mem_function_space_rel]

lemmas rel_Image_sub_codomain = Image_sub_codomain[OF mem_function_space_rel]

lemma rel_inj_to_Image: "⟦f:A→⇗M⇖B; f ∈ inj⇗M⇖(A,B); M(A); M(B)⟧ ⟹ f ∈ inj⇗M⇖(A,f``A)"
  using inj_to_Image[OF mem_function_space_rel mem_inj_rel]
    transM[OF _ function_space_rel_closed] by simp

lemma inj_rel_imp_surj_rel:
  fixes f b
  defines [simp]: "ifx(x) ≡ if x∈range(f) then converse(f)`x else b"
  assumes "f ∈ inj⇗M⇖(B,A)" "b∈B" and types: "M(f)" "M(B)" "M(A)"
  shows "(λx∈A. ifx(x)) ∈ surj⇗M⇖(A,B)"
proof -
  from types and ‹b∈B›
  have "M(λx∈A. ifx(x))"
    using ifx_replacement by (rule_tac lam_closed) (auto dest:transM)
  with assms(2-)
  show ?thesis
    using inj_imp_surj mem_surj_abs by simp
qed

lemma function_space_rel_disjoint_Un:
  assumes "f ∈ A→⇗M⇖B" "g ∈ C→⇗M⇖D"  "A ∩ C = 0"
    and types:"M(A)" "M(B)" "M(C)" "M(D)"
  shows "f ∪ g ∈ (A ∪ C)→⇗M⇖ (B ∪ D)"
  using assms fun_Pi_disjoint_Un[OF mem_function_space_rel
      mem_function_space_rel, OF assms(1) _ _ assms(2)]
    function_space_rel_char by auto

lemma restrict_eq_imp_Un_into_function_space_rel:
  assumes "f ∈ A→⇗M⇖B" "g ∈ C→⇗M⇖D"  "restrict(f, A ∩ C) = restrict(g, A ∩ C)"
    and types:"M(A)" "M(B)" "M(C)" "M(D)"
  shows "f ∪ g ∈ (A ∪ C)→⇗M⇖ (B ∪ D)"
  using assms restrict_eq_imp_Un_into_Pi[OF mem_function_space_rel
      mem_function_space_rel, OF assms(1) _ _ assms(2)]
    function_space_rel_char by auto

lemma lepoll_relD[dest]: "A ≲⇗M⇖ B ⟹ ∃f[M]. f ∈ inj⇗M⇖(A, B)"
  unfolding lepoll_rel_def .

― ‹Should the assumptions be on term‹f› or on term‹A› and term‹B›?
    Should BOTH be intro rules?›
lemma lepoll_relI[intro]: "f ∈ inj⇗M⇖(A, B) ⟹ M(f) ⟹ A ≲⇗M⇖ B"
  unfolding lepoll_rel_def by blast

lemma eqpollD[dest]: "A ≈⇗M⇖ B ⟹ ∃f[M]. f ∈ bij⇗M⇖(A, B)"
  unfolding eqpoll_rel_def .

― ‹Same as @{thm lepoll_relI}›
lemma bij_rel_imp_eqpoll_rel[intro]: "f ∈ bij⇗M⇖(A,B) ⟹ M(f) ⟹ A ≈⇗M⇖ B"
  unfolding eqpoll_rel_def by blast

lemma restrict_bij_rel:― ‹Unused›
  assumes "f ∈ inj⇗M⇖(A,B)"  "C⊆A"
    and types:"M(A)" "M(B)" "M(C)"
  shows "restrict(f,C)∈ bij⇗M⇖(C, f``C)"
  using assms restrict_bij inj_rel_char bij_rel_char by auto

lemma range_of_subset_eqpoll_rel:
  assumes "f ∈ inj⇗M⇖(X,Y)" "S ⊆ X"
    and types:"M(X)" "M(Y)" "M(S)"
  shows "S ≈⇗M⇖ f `` S"
  using assms restrict_bij bij_rel_char
    trans_inj_rel_closed[OF ‹f ∈ inj⇗M⇖(X,Y)›]
  unfolding eqpoll_rel_def
  by (rule_tac x="restrict(f,S)" in rexI) auto

lemmas inj_rel_is_fun = inj_is_fun[OF mem_inj_rel]

lemma inj_rel_bij_rel_range: "f ∈ inj⇗M⇖(A,B) ⟹ M(A) ⟹ M(B) ⟹ f ∈ bij⇗M⇖(A,range(f))"
  using bij_rel_char inj_rel_char inj_bij_range by force

lemma bij_rel_is_inj_rel: "f ∈ bij⇗M⇖(A,B) ⟹ M(A) ⟹ M(B) ⟹ f ∈ inj⇗M⇖(A,B)"
  unfolding bij_rel_def by simp

lemma inj_rel_weaken_type: "[| f ∈ inj⇗M⇖(A,B);  B⊆D; M(A); M(B); M(D) |] ==> f ∈ inj⇗M⇖(A,D)"
  using inj_rel_char inj_rel_is_fun inj_weaken_type by auto

lemma bij_rel_converse_bij_rel [TC]: "f ∈ bij⇗M⇖(A,B)  ⟹ M(A) ⟹ M(B) ==> converse(f): bij⇗M⇖(B,A)"
  using bij_rel_char by force

lemma bij_rel_is_fun_rel: "f ∈ bij⇗M⇖(A,B) ⟹ M(A) ⟹ M(B) ⟹  f ∈ A→⇗M⇖B"
  using bij_rel_char mem_function_space_rel_abs bij_is_fun by simp

lemmas bij_rel_is_fun = bij_rel_is_fun_rel[THEN mem_function_space_rel]

lemma comp_bij_rel:
  "g ∈ bij⇗M⇖(A,B) ⟹ f ∈ bij⇗M⇖(B,C) ⟹ M(A) ⟹ M(B) ⟹ M(C) ⟹ (f O g) ∈ bij⇗M⇖(A,C)"
  using bij_rel_char comp_bij by force

lemma inj_rel_converse_fun: "f ∈ inj⇗M⇖(A,B) ⟹ M(A) ⟹ M(B) ⟹ converse(f) ∈ range(f)→⇗M⇖A"
proof -
  assume "f ∈ inj⇗M⇖(A,B)" "M(A)" "M(B)"
  then
  have "M(f)" "M(converse(f))" "M(range(f))" "f∈inj(A,B)"
    using inj_rel_char converse_closed range_closed
    by auto
  then
  show ?thesis
    using inj_converse_inj function_space_rel_char inj_is_fun ‹M(A)› by auto
qed

lemma fg_imp_bijective_rel:
  assumes "f ∈ A →⇗M⇖B"  "g ∈ B→⇗M⇖A"  "f O g = id(B)" "g O f = id(A)" "M(A)" "M(B)"
  shows "f ∈ bij⇗M⇖(A,B)"
  using assms mem_bij_abs fg_imp_bijective mem_function_space_rel_abs[THEN iffD2] function_space_rel_char
  by auto

end ― ‹locale‹M_ZF_library››

(*************   Discipline for cexp   ****************)
relativize functional "cexp" "cexp_rel" external
relationalize "cexp_rel" "is_cexp"

context M_ZF_library
begin

is_iff_rel for "cexp"
  using is_cardinal_iff is_function_space_iff unfolding cexp_rel_def is_cexp_def
  by (simp)

rel_closed for "cexp" unfolding cexp_rel_def by simp

end ― ‹locale‹M_ZF_library››

synthesize "is_cexp" from_definition assuming "nonempty"
notation is_cexp_fm (‹⋅_⇗↑_⇖ is _⋅›)
arity_theorem for "is_cexp_fm"

abbreviation
  cexp_r :: "[i,i,i⇒o] ⇒ i"  (‹_⇗↑_,_⇖›) where
  "cexp_r(x,y,M) ≡ cexp_rel(M,x,y)"

abbreviation
  cexp_r_set :: "[i,i,i] ⇒ i"  (‹_⇗↑_,_⇖›) where
  "cexp_r_set(x,y,M) ≡ cexp_rel(##M,x,y)"

context M_ZF_library
begin

lemma Card_rel_cexp_rel: "M(κ) ⟹ M(ν) ⟹ Card⇗M⇖(κ⇗↑ν,M⇖)"
  unfolding cexp_rel_def by simp

― ‹Restoring congruence rule, but NOTE: beware›
declare conj_cong[cong]

lemma eq_csucc_rel_ord:
  "Ord(i) ⟹ M(i) ⟹ (i+)⇗M⇖ = (|i|⇗M⇖+)⇗M⇖"
  using Card_rel_lt_iff Least_cong unfolding csucc_rel_def by auto

lemma lesspoll_succ_rel:
  assumes "Ord(κ)" "M(κ)"
  shows "κ ≲⇗M⇖ (κ+)⇗M⇖"
  using csucc_rel_basic assms lt_Card_rel_imp_lesspoll_rel
    Card_rel_csucc_rel lepoll_rel_iff_leqpoll_rel
  by auto

lemma lesspoll_rel_csucc_rel:
  assumes "Ord(κ)"
    and types:"M(κ)" "M(d)"
  shows "d ≺⇗M⇖ (κ+)⇗M⇖ ⟷ d ≲⇗M⇖ κ"
proof
  assume "d ≺⇗M⇖ (κ+)⇗M⇖"
  moreover
  note Card_rel_csucc_rel assms Card_rel_is_Ord
  moreover from calculation
  have "Card⇗M⇖((κ+)⇗M⇖)" "M((κ+)⇗M⇖)" "Ord((κ+)⇗M⇖)"
    using Card_rel_is_Ord by simp_all
  moreover from calculation
  have "d ≺⇗M⇖ (|κ|⇗M⇖+)⇗M⇖" "d ≈⇗M⇖ |d|⇗M⇖"
    using eq_csucc_rel_ord[OF _ ‹M(κ)›]
      lesspoll_rel_imp_eqpoll_rel eqpoll_rel_sym by simp_all
  moreover from calculation
  have "|d|⇗M⇖ < (|κ|⇗M⇖+)⇗M⇖"
    using lesspoll_cardinal_lt_rel by simp
  moreover from calculation
  have "|d|⇗M⇖ ≲⇗M⇖ |κ|⇗M⇖"
    using Card_rel_lt_csucc_rel_iff le_imp_lepoll_rel by simp
  moreover from calculation
  have "|d|⇗M⇖ ≲⇗M⇖ κ"
    using Ord_cardinal_rel_eqpoll_rel lepoll_rel_eq_trans
    by simp
  ultimately
  show "d ≲⇗M⇖ κ"
    using eq_lepoll_rel_trans by simp
next
  from ‹Ord(κ)›
  have "κ < (κ+)⇗M⇖" "Card⇗M⇖((κ+)⇗M⇖)" "M((κ+)⇗M⇖)"
    using Card_rel_csucc_rel lt_csucc_rel_iff types eq_csucc_rel_ord[OF _ ‹M(κ)›]
    by simp_all
  then
  have "κ ≺⇗M⇖ (κ+)⇗M⇖"
    using lt_Card_rel_imp_lesspoll_rel[OF _ ‹κ <_›] types by simp
  moreover
  assume "d ≲⇗M⇖ κ"
  ultimately
  have "d ≲⇗M⇖ (κ+)⇗M⇖"
    using Card_rel_csucc_rel types lesspoll_succ_rel lepoll_rel_trans ‹Ord(κ)›
    by simp
  moreover
  from ‹d ≲⇗M⇖ κ› ‹Ord(κ)›
  have "(κ+)⇗M⇖ ≲⇗M⇖ κ" if "d ≈⇗M⇖ (κ+)⇗M⇖"
    using eqpoll_rel_sym[OF that] types eq_lepoll_rel_trans[OF _ ‹d≲⇗M⇖κ›]
    by simp
  moreover from calculation ‹κ ≺⇗M⇖ (κ+)⇗M⇖›
  have False if "d ≈⇗M⇖ (κ+)⇗M⇖"
    using lesspoll_rel_irrefl[OF _ ‹M((κ+)⇗M⇖)›] lesspoll_rel_trans1 types that
    by auto
  ultimately
  show "d ≺⇗M⇖ (κ+)⇗M⇖"
    unfolding lesspoll_rel_def by auto
qed

lemma Infinite_imp_nats_lepoll:
  assumes "Infinite(X)" "n ∈ ω"
  shows "n ≲ X"
  using ‹n ∈ ω›
proof (induct)
  case 0
  then
  show ?case using empty_lepollI by simp
next
  case (succ x)
  show ?case
  proof -
    from ‹Infinite(X)› and ‹x ∈ ω›
    have "¬ (x ≈ X)"
      using eqpoll_sym unfolding Finite_def by auto
    with ‹x ≲ X›
    obtain f where "f ∈ inj(x,X)" "f ∉ surj(x,X)"
      unfolding bij_def eqpoll_def by auto
    moreover from this
    obtain b where "b ∈ X" "∀a∈x. f`a ≠ b"
      using inj_is_fun unfolding surj_def by auto
    ultimately
    have "f ∈ inj(x,X-{b})"
      unfolding inj_def by (auto intro:Pi_type)
    then
    have "cons(⟨x, b⟩, f) ∈ inj(succ(x), cons(b, X - {b}))"
      using inj_extend[of f x "X-{b}" x b] unfolding succ_def
      by (auto dest:mem_irrefl)
    moreover from ‹b∈X›
    have "cons(b, X - {b}) = X" by auto
    ultimately
    show "succ(x) ≲ X" by auto
  qed
qed

lemma nepoll_imp_nepoll_rel :
  assumes "¬ x ≈ X" "M(x)" "M(X)"
  shows "¬ (x ≈⇗M⇖ X)"
  using assms unfolding eqpoll_def eqpoll_rel_def by simp

lemma Infinite_imp_nats_lepoll_rel:
  assumes "Infinite(X)" "n ∈ ω"
    and types: "M(X)"
  shows "n ≲⇗M⇖ X"
  using ‹n ∈ ω›
proof (induct)
  case 0
  then
  show ?case using empty_lepoll_relI types by simp
next
  case (succ x)
  show ?case
  proof -
    from ‹Infinite(X)› and ‹x ∈ ω›
    have "¬ (x ≈ X)" "M(x)" "M(succ(x))"
      using eqpoll_sym unfolding Finite_def by auto
    then
    have "¬ (x ≈⇗M⇖ X)"
      using nepoll_imp_nepoll_rel types by simp
    with ‹x ≲⇗M⇖ X›
    obtain f where "f ∈ inj⇗M⇖(x,X)" "f ∉ surj⇗M⇖(x,X)" "M(f)"
      unfolding bij_rel_def eqpoll_rel_def by auto
    with ‹M(X)› ‹M(x)›
    have "f∉surj(x,X)" "f∈inj(x,X)"
      using surj_rel_char by simp_all
    moreover
    from this
    obtain b where "b ∈ X" "∀a∈x. f`a ≠ b"
      using inj_is_fun unfolding surj_def by auto
    moreover
    from this calculation ‹M(x)›
    have "f ∈ inj(x,X-{b})" "M(<x,b>)"
      unfolding inj_def using transM[OF _ ‹M(X)›]
      by (auto intro:Pi_type)
    moreover
    from this
    have "cons(⟨x, b⟩, f) ∈ inj(succ(x), cons(b, X - {b}))" (is "?g∈_")
      using inj_extend[of f x "X-{b}" x b] unfolding succ_def
      by (auto dest:mem_irrefl)
    moreover
    note ‹M(<x,b>)› ‹M(f)› ‹b∈X› ‹M(X)› ‹M(succ(x))›
    moreover from this
    have "M(?g)" "cons(b, X - {b}) = X" by auto
    moreover from calculation
    have "?g∈inj_rel(M,succ(x),X)"
      using mem_inj_abs by simp
    with ‹M(?g)›
    show "succ(x) ≲⇗M⇖ X" using lepoll_relI by simp
  qed
qed

lemma lepoll_rel_imp_lepoll: "A ≲⇗M⇖ B ⟹ M(A) ⟹ M(B) ⟹ A ≲ B"
  unfolding lepoll_rel_def by auto

lemma zero_lesspoll_rel: assumes "0<κ" "M(κ)" shows "0 ≺⇗M⇖ κ"
  using assms eqpoll_rel_0_iff[THEN iffD1, of κ] eqpoll_rel_sym
  unfolding lesspoll_rel_def lepoll_rel_def
  by (auto simp add:inj_def)

lemma lepoll_rel_nat_imp_Infinite: "ω ≲⇗M⇖ X ⟹ M(X) ⟹ Infinite(X)"
  using  lepoll_nat_imp_Infinite lepoll_rel_imp_lepoll by simp

lemma InfCard_rel_imp_Infinite: "InfCard⇗M⇖(κ) ⟹ M(κ) ⟹ Infinite(κ)"
  using le_imp_lepoll_rel[THEN lepoll_rel_nat_imp_Infinite, of κ]
  unfolding InfCard_rel_def by simp

lemma lt_surj_rel_empty_imp_Card_rel:
  assumes "Ord(κ)" "⋀α. α < κ ⟹ surj⇗M⇖(α,κ) = 0"
    and types:"M(κ)"
  shows "Card⇗M⇖(κ)"
proof -
  {
    define min where "min≡μ x. ∃f[M]. f ∈ bij⇗M⇖(x,κ)"
    moreover
    note ‹Ord(κ)› ‹M(κ)›
    moreover
    assume "|κ|⇗M⇖ < κ"
    moreover from calculation
    have "∃f. f ∈ bij⇗M⇖(min,κ)"
      using LeastI[of "λi. i ≈⇗M⇖ κ" κ, OF eqpoll_rel_refl]
      unfolding Card_rel_def cardinal_rel_def eqpoll_rel_def
      by (auto)
    moreover from calculation
    have "min < κ"
      using lt_trans1[of min "μ i. M(i) ∧ (∃f[M]. f ∈ bij⇗M⇖(i, κ))" κ]
        Least_le[of "λi. i ≈⇗M⇖ κ" "|κ|⇗M⇖", OF Ord_cardinal_rel_eqpoll_rel]
      unfolding Card_rel_def cardinal_rel_def eqpoll_rel_def
      by (simp)
    moreover
    note ‹min < κ ⟹ surj⇗M⇖(min,κ) = 0›
    ultimately
    have "False"
      unfolding bij_rel_def by simp
  }
  with assms
  show ?thesis
    using Ord_cardinal_rel_le[of κ] not_lt_imp_le[of "|κ|⇗M⇖" κ] le_anti_sym
    unfolding Card_rel_def by auto
qed

end ― ‹locale‹M_ZF_library››

relativize functional "mono_map" "mono_map_rel" external
relationalize "mono_map_rel" "is_mono_map"
synthesize "is_mono_map" from_definition assuming "nonempty"

notation mono_map_rel (‹mono'_map⇗_⇖'(_,_,_,_')›)

abbreviation
  mono_map_r_set  :: "[i,i,i,i,i]⇒i"  (‹mono'_map⇗_⇖'(_,_,_,_')›) where
  "mono_map⇗M⇖(a,r,b,s) ≡ mono_map_rel(##M,a,r,b,s)"

context M_ZF_library
begin

lemma mono_map_rel_char:
  assumes "M(a)" "M(b)"
  shows "mono_map⇗M⇖(a,r,b,s) = {f∈mono_map(a,r,b,s) . M(f)}"
  using assms function_space_rel_char unfolding mono_map_rel_def mono_map_def
  by auto

text‹Just a sample of porting results on term‹mono_map››
lemma mono_map_rel_mono:
  assumes
    "f ∈ mono_map⇗M⇖(A,r,B,s)" "B ⊆ C"
    and types:"M(A)" "M(B)" "M(C)"
  shows
    "f ∈ mono_map⇗M⇖(A,r,C,s)"
  using assms mono_map_mono mono_map_rel_char by auto

lemma nats_le_InfCard_rel:
  assumes "n ∈ ω" "InfCard⇗M⇖(κ)"
  shows "n ≤ κ"
  using assms Ord_is_Transset
    le_trans[of n ω κ, OF le_subset_iff[THEN iffD2]]
  unfolding InfCard_rel_def Transset_def by simp

lemma nat_into_InfCard_rel:
  assumes "n ∈ ω" "InfCard⇗M⇖(κ)"
  shows "n ∈ κ"
  using assms  le_imp_subset[of ω κ]
  unfolding InfCard_rel_def by auto

lemma Finite_lesspoll_rel_nat:
  assumes "Finite(x)" "M(x)"
  shows "x ≺⇗M⇖ nat"
proof -
  note assms
  moreover from this
  obtain n where "n ∈ ω" "M(n)" "x ≈ n"
    unfolding Finite_def by auto
  moreover from calculation
  obtain f where "f ∈ bij(x,n)" "f: x-||>n"
    using Finite_Fin[THEN fun_FiniteFunI, OF _ subset_refl] bij_is_fun
    unfolding eqpoll_def by auto
  ultimately
  have "x≈⇗M⇖ n" unfolding eqpoll_rel_def by (auto dest:transM)
  with assms and ‹M(n)›
  have "n ≈⇗M⇖ x" using eqpoll_rel_sym by simp
  moreover
  note ‹n∈ω› ‹M(n)›
  ultimately
  show ?thesis
    using assms eq_lesspoll_rel_trans[OF ‹x≈⇗M⇖ n› n_lesspoll_rel_nat]
    by simp
qed

lemma Finite_cardinal_rel_in_nat [simp]:
  assumes "Finite(A)" "M(A)" shows "|A|⇗M⇖ ∈ ω"
proof -
  note assms
  moreover from this
  obtain n where "n ∈ ω" "M(n)" "A ≈ n"
    unfolding Finite_def by auto
  moreover from calculation
  obtain f where "f ∈ bij(A,n)" "f: A-||>n"
    using Finite_Fin[THEN fun_FiniteFunI, OF _ subset_refl] bij_is_fun
    unfolding eqpoll_def by auto
  ultimately
  have "A ≈⇗M⇖ n" unfolding eqpoll_rel_def by (auto dest:transM)
  with assms and ‹M(n)›
  have "n ≈⇗M⇖ A" using eqpoll_rel_sym by simp
  moreover
  note ‹n∈ω› ‹M(n)›
  ultimately
  show ?thesis
    using assms Least_le[of "λi. M(i) ∧ i ≈⇗M⇖ A" n]
      lt_trans1[of _ n ω, THEN ltD]
    unfolding cardinal_rel_def Finite_def
    by (auto dest!:naturals_lt_nat)
qed

lemma Finite_cardinal_rel_eq_cardinal:
  assumes "Finite(A)" "M(A)" shows "|A|⇗M⇖ = |A|"
proof -
  ― ‹Copy-paste from @{thm Finite_cardinal_rel_in_nat}›
  note assms
  moreover from this
  obtain n where "n ∈ ω" "M(n)" "A ≈ n"
    unfolding Finite_def by auto
  moreover from this
  have "|A| = n"
    using cardinal_cong[of A n]
      nat_into_Card[THEN Card_cardinal_eq, of n] by simp
  moreover from calculation
  obtain f where "f ∈ bij(A,n)" "f: A-||>n"
    using Finite_Fin[THEN fun_FiniteFunI, OF _ subset_refl] bij_is_fun
    unfolding eqpoll_def by auto
  ultimately
  have "A ≈⇗M⇖ n" unfolding eqpoll_rel_def by (auto dest:transM)
  with assms and ‹M(n)› ‹n∈ω›
  have "|A|⇗M⇖ = n"
    using cardinal_rel_cong[of A n]
      nat_into_Card_rel[THEN Card_rel_cardinal_rel_eq, of n]
    by simp
  with ‹|A| = n›
  show ?thesis by simp
qed

lemma Finite_imp_cardinal_rel_cons:
  assumes FA: "Finite(A)" and a: "a∉A" and types:"M(A)" "M(a)"
  shows "|cons(a,A)|⇗M⇖ = succ(|A|⇗M⇖)"
  using assms Finite_imp_cardinal_cons Finite_cardinal_rel_eq_cardinal by simp

lemma Finite_imp_succ_cardinal_rel_Diff:
  assumes "Finite(A)" "a ∈ A" "M(A)"
  shows "succ(|A-{a}|⇗M⇖) = |A|⇗M⇖"
proof -
  from assms
  have inM: "M(A-{a})" "M(a)" "M(A)" by (auto dest:transM)
  with ‹Finite(A)›
  have "succ(|A-{a}|⇗M⇖) = succ(|A-{a}|)"
    using Diff_subset[THEN subset_Finite,
        THEN Finite_cardinal_rel_eq_cardinal, of A "{a}"] by simp
  also from assms
  have "… = |A|"
    using Finite_imp_succ_cardinal_Diff by simp
  also from assms
  have "… = |A|⇗M⇖" using Finite_cardinal_rel_eq_cardinal by simp
  finally
  show ?thesis .
qed

lemma InfCard_rel_Aleph_rel:
  notes Aleph_rel_zero[simp]
  assumes "Ord(α)"
    and types: "M(α)"
  shows "InfCard⇗M⇖(ℵ⇘α⇙⇗M⇖)"
proof -
  have "¬ (ℵ⇘α⇙⇗M⇖ ∈ ω)"
  proof (cases "α=0")
    case True
    then show ?thesis using mem_irrefl by auto
  next
    case False
    with assms
    have "ω ∈ ℵ⇘α⇙⇗M⇖" using Ord_0_lt[of α] ltD by (auto dest:Aleph_rel_increasing)
    then show ?thesis using foundation by blast
  qed
  with assms
  have "¬ (|ℵ⇘α⇙⇗M⇖|⇗M⇖ ∈ ω)"
    using Card_rel_cardinal_rel_eq by auto
  with assms
  have "Infinite(ℵ⇘α⇙⇗M⇖)" using Ord_Aleph_rel by clarsimp
  with assms
  show ?thesis
    using Inf_Card_rel_is_InfCard_rel by simp
qed

lemmas Limit_Aleph_rel = InfCard_rel_Aleph_rel[THEN InfCard_rel_is_Limit]

bundle Ord_dests = Limit_is_Ord[dest] Card_rel_is_Ord[dest]
bundle Aleph_rel_dests = Aleph_rel_cont[dest]
bundle Aleph_rel_intros = Aleph_rel_increasing[intro!]
bundle Aleph_rel_mem_dests = Aleph_rel_increasing[OF ltI, THEN ltD, dest]

lemma f_imp_injective_rel:
  assumes "f ∈ A →⇗M⇖ B" "∀x∈A. d(f ` x) = x" "M(A)" "M(B)"
  shows "f ∈ inj⇗M⇖(A, B)"
  using assms
  apply (simp (no_asm_simp) add: def_inj_rel)
  apply (auto intro: subst_context [THEN box_equals])
  done

lemma lam_injective_rel:
  assumes "⋀x. x ∈ A ⟹ c(x) ∈ B"
    "⋀x. x ∈ A ⟹ d(c(x)) = x"
    "∀x[M]. M(c(x))" "lam_replacement(M,c)"
    "M(A)" "M(B)"
  shows "(λx∈A. c(x)) ∈ inj⇗M⇖(A, B)"
  using assms function_space_rel_char lam_replacement_iff_lam_closed
  by (rule_tac d = d in f_imp_injective_rel)
    (auto simp add: lam_type)

lemma f_imp_surjective_rel:
  assumes "f ∈ A →⇗M⇖ B" "⋀y. y ∈ B ⟹ d(y) ∈ A" "⋀y. y ∈ B ⟹ f ` d(y) = y"
    "M(A)" "M(B)"
  shows "f ∈ surj⇗M⇖(A, B)"
  using assms
  by (simp add: def_surj_rel, blast)

lemma lam_surjective_rel:
  assumes "⋀x. x ∈ A ⟹ c(x) ∈ B"
    "⋀y. y ∈ B ⟹ d(y) ∈ A"
    "⋀y. y ∈ B ⟹ c(d(y)) = y"
    "∀x[M]. M(c(x))" "lam_replacement(M,c)"
    "M(A)" "M(B)"
  shows "(λx∈A. c(x)) ∈ surj⇗M⇖(A, B)"
  using assms function_space_rel_char lam_replacement_iff_lam_closed
  by (rule_tac d = d in f_imp_surjective_rel)
    (auto simp add: lam_type)

lemma lam_bijective_rel:
  assumes "⋀x. x ∈ A ⟹ c(x) ∈ B"
    "⋀y. y ∈ B ⟹ d(y) ∈ A"
    "⋀x. x ∈ A ⟹ d(c(x)) = x"
    "⋀y. y ∈ B ⟹ c(d(y)) = y"
    "∀x[M]. M(c(x))" "lam_replacement(M,c)"
    "M(A)" "M(B)"
  shows "(λx∈A. c(x)) ∈ bij⇗M⇖(A, B)"
  using assms
  apply (unfold bij_rel_def)
  apply (blast intro!: lam_injective_rel lam_surjective_rel)
  done

lemma function_space_rel_eqpoll_rel_cong:
  assumes
    "A ≈⇗M⇖ A'" "B ≈⇗M⇖ B'" "M(A)" "M(A')" "M(B)" "M(B')"
  shows
    "A →⇗M⇖ B ≈⇗M⇖ A' →⇗M⇖ B'"
proof -
  from assms(1)[THEN eqpoll_rel_sym] assms(2) assms lam_type
  obtain f g where "f ∈ bij⇗M⇖(A',A)" "g ∈ bij⇗M⇖(B,B')"
    by blast
  with assms
  have "converse(g) : bij⇗M⇖(B', B)" "converse(f): bij⇗M⇖(A, A')"
    using bij_converse_bij by auto
  let ?H="λ h ∈ A →⇗M⇖ B . g O h O f"
  let ?I="λ h ∈ A' →⇗M⇖ B' . converse(g) O h O converse(f)"
  have go:"g O F O f : A' →⇗M⇖ B'" if "F: A →⇗M⇖ B" for F
  proof -
    note assms ‹f∈_› ‹g∈_› that
    moreover from this
    have "g O F O f : A' → B'"
      using bij_rel_is_fun[OF ‹g∈_›] bij_rel_is_fun[OF ‹f∈_›] comp_fun
        mem_function_space_rel[OF ‹F∈_›]
      by blast
    ultimately
    show "g O F O f : A' →⇗M⇖ B'"
      using comp_closed function_space_rel_char bij_rel_char
      by auto
  qed
  have og:"converse(g) O F O converse(f) : A →⇗M⇖ B" if "F: A' →⇗M⇖ B'" for F
  proof -
    note assms that ‹converse(f) ∈ _› ‹converse(g) ∈ _›
    moreover from this
    have "converse(g) O F O converse(f) : A → B"
      using bij_rel_is_fun[OF ‹converse(g)∈_›] bij_rel_is_fun[OF ‹converse(f)∈_›] comp_fun
        mem_function_space_rel[OF ‹F∈_›]
      by blast
    ultimately
    show "converse(g) O F O converse(f) : A →⇗M⇖ B" (is "?G∈_")
      using comp_closed function_space_rel_char bij_rel_char
      by auto
  qed
  with go
  have tc:"?H ∈ (A →⇗M⇖ B) → (A'→⇗M⇖ B')" "?I ∈ (A' →⇗M⇖ B') → (A→⇗M⇖ B)"
    using lam_type by auto
  with assms ‹f∈_› ‹g∈_›
  have "M(g O x O f)" and "M(converse(g) O x O converse(f))" if "M(x)" for x
    using bij_rel_char comp_closed that by auto
  with assms ‹f∈_› ‹g∈_›
  have "M(?H)" "M(?I)"
    using lam_replacement_iff_lam_closed[THEN iffD1,OF _ lam_replacement_comp']
      bij_rel_char by auto
  show ?thesis
    unfolding eqpoll_rel_def
  proof (intro rexI[of _ ?H] fg_imp_bijective_rel)
    from og go
    have "(⋀x. x ∈ A' →⇗M⇖ B' ⟹ converse(g) O x O converse(f) ∈ A →⇗M⇖ B)"
      by simp
  next
    show "M(A →⇗M⇖ B)" using assms by simp
  next
    show "M(A' →⇗M⇖ B')" using assms by simp
  next
    from og assms
    have "?H O ?I = (λx∈A' →⇗M⇖ B' . (g O converse(g)) O x O (converse(f) O f))"
      using lam_cong[OF refl[of "A' →⇗M⇖ B'"]] comp_assoc comp_lam
      by auto
    also
    have "... = (λx∈A' →⇗M⇖ B' . id(B') O x O (id(A')))"
      using left_comp_inverse[OF mem_inj_rel[OF bij_rel_is_inj_rel]] ‹f∈_›
        right_comp_inverse[OF bij_is_surj[OF mem_bij_rel]] ‹g∈_› assms
      by auto
    also
    have "... = (λx∈A' →⇗M⇖ B' . x)"
      using left_comp_id[OF fun_is_rel[OF mem_function_space_rel]]
        right_comp_id[OF fun_is_rel[OF mem_function_space_rel]] assms
      by auto
    also
    have "... = id(A'→⇗M⇖B')" unfolding id_def by simp
    finally
    show "?H O ?I = id(A' →⇗M⇖ B')" .
  next
    from go assms
    have "?I O ?H = (λx∈A →⇗M⇖ B . (converse(g) O g) O x O (f O converse(f)))"
      using lam_cong[OF refl[of "A →⇗M⇖ B"]] comp_assoc comp_lam by auto
    also
    have "... = (λx∈A →⇗M⇖ B . id(B) O x O (id(A)))"
      using
        left_comp_inverse[OF mem_inj_rel[OF bij_rel_is_inj_rel[OF ‹g∈_›]]]
        right_comp_inverse[OF bij_is_surj[OF mem_bij_rel[OF ‹f∈_›]]] assms
      by auto
    also
    have "... = (λx∈A →⇗M⇖ B . x)"
      using left_comp_id[OF fun_is_rel[OF mem_function_space_rel]]
        right_comp_id[OF fun_is_rel[OF mem_function_space_rel]]
        assms
      by auto
    also
    have "... = id(A→⇗M⇖B)" unfolding id_def by simp
    finally
    show "?I O ?H = id(A →⇗M⇖ B)" .
  next
    from assms tc ‹M(?H)› ‹M(?I)›
    show "?H ∈ (A→⇗M⇖ B) →⇗M⇖ (A'→⇗M⇖ B')" "M(?H)"
      "?I ∈ (A'→⇗M⇖ B') →⇗M⇖ (A→⇗M⇖ B)"
      using mem_function_space_rel_abs by auto
  qed
qed

lemma curry_eqpoll_rel:
  fixes ν1 ν2  κ
  assumes  "M(ν1)" "M(ν2)" "M(κ)"
  shows "ν1 →⇗M⇖ (ν2 →⇗M⇖ κ) ≈⇗M⇖ ν1 × ν2 →⇗M⇖ κ"
  unfolding eqpoll_rel_def
proof (intro rexI, rule lam_bijective_rel,
    rule_tac [1-2] mem_function_space_rel_abs[THEN iffD2],
    rule_tac [4] lam_type, rule_tac [8] lam_type,
    rule_tac [8] mem_function_space_rel_abs[THEN iffD2],
    rule_tac [11] lam_type, simp_all add:assms)
  let ?cur="λx. λw∈ν1 × ν2. x ` fst(w) ` snd(w)"
  fix f z
  assume "f : ν1 →⇗M⇖ (ν2 →⇗M⇖ κ)"
  moreover
  note assms
  moreover from calculation
  have "M(ν2 →⇗M⇖ κ)"
    using function_space_rel_closed by simp
  moreover from calculation
  have "M(f)" "f : ν1 → (ν2 →⇗M⇖ κ)"
    using function_space_rel_char by (auto dest:transM)
  moreover from calculation
  have "x ∈ ν1 ⟹ f`x : ν2 → κ" for x
    by (auto dest:transM intro!:mem_function_space_rel_abs[THEN iffD1])
  moreover from this
  show "(λa∈ν1. λb∈ν2. ?cur(f) ` ⟨a, b⟩) = f"
    using Pi_type[OF ‹f ∈ ν1 → ν2 →⇗M⇖ κ›, of "λ_.ν2 → κ"] by simp
  moreover
  assume "z ∈ ν1 × ν2"
  moreover from calculation
  have "f`fst(z): ν2 →⇗M⇖ κ" by simp
  ultimately
  show "f`fst(z)`snd(z) ∈ κ"
    using mem_function_space_rel_abs by (auto dest:transM)
next ― ‹one composition is the identity:›
  let ?cur="λx. λw∈ν1 × ν2. x ` fst(w) ` snd(w)"
  fix f
  assume "f : ν1 × ν2 →⇗M⇖ κ"
  with assms
  show "?cur(λx∈ν1. λxa∈ν2. f ` ⟨x, xa⟩) = f"
    using function_space_rel_char mem_function_space_rel_abs
    by (auto dest:transM intro:fun_extension)
  fix x y
  assume "x∈ν1" "y∈ν2"
  with assms ‹f : ν1 × ν2 →⇗M⇖ κ›
  show "f`⟨x,y⟩ ∈ κ"
    using function_space_rel_char mem_function_space_rel_abs
    by (auto dest:transM[of _ "ν1 × ν2 →⇗M⇖ κ"])
next
  let ?cur="λx. λw∈ν1 × ν2. x ` fst(w) ` snd(w)"
  note assms
  moreover from this
  show "∀x[M]. M(?cur(x))"
    using  lam_replacement_fst lam_replacement_snd
      lam_replacement_apply2[THEN [5] lam_replacement_hcomp2,
        THEN [1] lam_replacement_hcomp2, where h="(`)", OF
        lam_replacement_constant] lam_replacement_apply2
    by (auto intro: lam_replacement_iff_lam_closed[THEN iffD1, rule_format])
  moreover from calculation
  show "x ∈ ν1 →⇗M⇖ (ν2 →⇗M⇖ κ) ⟹ M(?cur(x))" for x
    by (auto dest:transM)
  moreover from assms
  show "lam_replacement(M, ?cur)"
    using lam_replacement_Lambda_apply_fst_snd by simp
  ultimately
  show "M(λx∈ν1 →⇗M⇖ (ν2 →⇗M⇖ κ). ?cur(x))"
    using lam_replacement_iff_lam_closed
    by (auto dest:transM)
  from assms
  show "y ∈ ν1 × ν2 →⇗M⇖ κ ⟹ x ∈ ν1 ⟹ M(λxa∈ν2. y ` ⟨x, xa⟩)" for x y
    using lam_replacement_apply_const_id
    by (rule_tac lam_replacement_iff_lam_closed[THEN iffD1, rule_format])
      (auto dest:transM)
  from assms
  show "y ∈ ν1 × ν2 →⇗M⇖ κ ⟹ M(λx∈ν1. λxa∈ν2. y ` ⟨x, xa⟩)" for y
    using lam_replacement_apply2[THEN [5] lam_replacement_hcomp2,
        OF lam_replacement_constant lam_replacement_const_id]
      lam_replacement_Lambda_apply_Pair[of ν2]
    by (auto dest:transM
        intro!: lam_replacement_iff_lam_closed[THEN iffD1, rule_format])
qed

lemma Pow_rel_eqpoll_rel_function_space_rel:
  fixes d X
  notes bool_of_o_def [simp]
  defines [simp]:"d(A) ≡ (λx∈X. bool_of_o(x∈A))"
    ― ‹the witnessing map for the thesis:›
  assumes "M(X)"
  shows "Pow⇗M⇖(X) ≈⇗M⇖ X →⇗M⇖ 2"
proof -
  from assms
  interpret M_Pi_assumptions M X "λ_. 2"
    using Pi_replacement Pi_separation lam_replacement_identity
      lam_replacement_Sigfun[THEN lam_replacement_imp_strong_replacement]
      Pi_replacement1[of _ 2] transM[of _ X] lam_replacement_constant
    by unfold_locales auto
  have "lam_replacement(M, λx. bool_of_o(x∈A))" if "M(A)" for A
    using that lam_replacement_if lam_replacement_constant
      separation_in_constant by simp
  with assms
  have "lam_replacement(M, λx. d(x))"
    using separation_in_constant[THEN [3] lam_replacement_if, of "λ_.1" "λ_.0"]
      lam_replacement_identity lam_replacement_constant lam_replacement_Lambda_if_mem
    by simp
  show ?thesis
    unfolding eqpoll_rel_def
  proof (intro rexI, rule lam_bijective_rel)
    ― ‹We give explicit mutual inverses›
    fix A
    assume "A∈Pow⇗M⇖(X)"
    moreover
    note ‹M(X)›
    moreover from calculation
    have "M(A)" by (auto dest:transM)
    moreover
    note ‹_ ⟹ lam_replacement(M, λx. bool_of_o(x∈A))›
    ultimately
    show "d(A) : X →⇗M⇖ 2"
      using function_space_rel_char lam_replacement_iff_lam_closed[THEN iffD1]
      by (simp, rule_tac lam_type[of X "λx. bool_of_o(x∈A)" "λ_. 2", simplified])
        auto
    from ‹A∈Pow⇗M⇖(X)› ‹M(X)›
    show "{y∈X. d(A)`y = 1} = A"
      using Pow_rel_char by auto
  next
    fix f
    assume "f: X→⇗M⇖ 2"
    with assms
    have "f: X→ 2" "M(f)" using function_space_rel_char by simp_all
    then
    show "d({y ∈ X . f ` y = 1}) = f"
      using apply_type[OF ‹f: X→2›] by (force intro:fun_extension)
    from ‹M(X)› ‹M(f)›
    show "{ya ∈ X . f ` ya = 1} ∈ Pow⇗M⇖(X)"
      using Pow_rel_char separation_equal_apply by auto
  next
    from assms ‹lam_replacement(M, λx. d(x))›
      ‹⋀A. _ ⟹ lam_replacement(M, λx. bool_of_o(x∈A))›
    show "M(λx∈Pow⇗M⇖(X). d(x))" "lam_replacement(M, λx. d(x))"
      "∀x[M]. M(d(x))"
      using lam_replacement_iff_lam_closed[THEN iffD1] by auto
  qed (auto simp:‹M(X)›)
qed

lemma Pow_rel_bottom: "M(B) ⟹ 0 ∈ Pow⇗M⇖(B)"
  using Pow_rel_char by simp

lemma cantor_surj_rel:
  assumes "M(f)" "M(A)"
  shows "f ∉ surj⇗M⇖(A,Pow⇗M⇖(A))"
proof
  assume "f ∈ surj⇗M⇖(A,Pow⇗M⇖(A))"
  with assms
  have "f ∈ surj(A,Pow⇗M⇖(A))" using surj_rel_char by simp
  moreover
  note assms
  moreover from this
  have "M({x ∈ A . x ∈ f ` x})" "{x ∈ A . x ∉ f ` x} = A - {x ∈ A . x ∈ f ` x}"
    using lam_replacement_apply[THEN [4] separation_in, of  "λx. x"]
      lam_replacement_identity lam_replacement_constant by auto
  with ‹M(A)›
  have "{x∈A . x ∉ f`x} ∈ Pow⇗M⇖(A)"
    by (intro mem_Pow_rel_abs[THEN iffD2]) auto
  ultimately
  obtain d where "d∈A" "f`d = {x∈A . x ∉ f`x}"
    unfolding surj_def by blast
  show False
  proof (cases "d ∈ f`d")
    case True
    note ‹d ∈ f`d›
    also
    note ‹f`d = {x∈A . x ∉ f`x}›
    finally
    have "d ∉ f`d" using ‹d∈A› by simp
    then
    show False using ‹d ∈ f ` d› by simp
  next
    case False
    with ‹d∈A›
    have "d ∈ {x∈A . x ∉ f`x}" by simp
    also from ‹f`d = …›
    have "… = f`d" by simp
    finally
    show False using ‹d ∉ f`d› by simp
  qed
qed

lemma cantor_inj_rel: "M(f) ⟹ M(A) ⟹ f ∉ inj⇗M⇖(Pow⇗M⇖(A),A)"
  using inj_rel_imp_surj_rel[OF _ Pow_rel_bottom, of f A A]
    cantor_surj_rel[of "λx∈A. if x ∈ range(f) then converse(f) ` x else 0" A]
    lam_replacement_if separation_in_constant[of "range(f)"]
    lam_replacement_converse_app[THEN [5] lam_replacement_hcomp2]
    lam_replacement_identity lam_replacement_constant
    lam_replacement_iff_lam_closed by auto

end ― ‹locale‹M_ZF_library››

end

Theory Replacement_Lepoll

section‹Lambda-replacements required for cardinal inequalities›

theory Replacement_Lepoll
  imports
    ZF_Library_Relative
begin

definition
  lepoll_assumptions1 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions1(M,A,F,S,fa,K,x,f,r) ≡ ∀x∈S. strong_replacement(M, λy z. y ∈ F(A, x) ∧ z = {⟨x, y⟩})"

definition
  lepoll_assumptions2 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions2(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement(M, λx z. z = Sigfun(x, F(A)))"

definition
  lepoll_assumptions3 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions3(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement(M, λx y. y = F(A, x))"

definition
  lepoll_assumptions4 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions4(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement(M, λx y. y = ⟨x, minimum(r, F(A, x))⟩)"

definition
  lepoll_assumptions5 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions5(M,A,F,S,fa,K,x,f,r) ≡
strong_replacement(M, λx y. y = ⟨x, μ i. x ∈ F(A, i), f ` (μ i. x ∈ F(A, i)) ` x⟩)"

definition
  lepoll_assumptions6 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions6(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement(M, λy z. y ∈ inj⇗M⇖(F(A, x),S) ∧ z = {⟨x, y⟩})"

definition
  lepoll_assumptions7 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions7(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement(M, λx y. y = inj⇗M⇖(F(A, x),S))"

definition
  lepoll_assumptions8 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions8(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement(M, λx z. z = Sigfun(x, λi. inj⇗M⇖(F(A, i),S)))"

definition
  lepoll_assumptions9 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions9(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement(M, λx y. y = ⟨x, minimum(r, inj⇗M⇖(F(A, x),S))⟩)"

definition
  lepoll_assumptions10 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions10(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement
           (M, λx z. z = Sigfun(x, λk. if k ∈ range(f) then F(A, converse(f) ` k) else 0))"

definition
  lepoll_assumptions11 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions11(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement(M, λx y. y = (if x ∈ range(f) then F(A, converse(f) ` x) else 0))"

definition
  lepoll_assumptions12 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions12(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement(M, λy z. y ∈ F(A, converse(f) ` x) ∧ z = {⟨x, y⟩})"

definition
  lepoll_assumptions13 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions13(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement
         (M, λx y. y = ⟨x, minimum(r, if x ∈ range(f) then F(A,converse(f) ` x) else 0)⟩)"

definition
  lepoll_assumptions14 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions14(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement
         (M, λx y. y = ⟨x, μ i. x ∈ (if i ∈ range(f) then F(A, converse(f) ` i) else 0),
                        fa ` (μ i. x ∈ (if i ∈ range(f) then F(A, converse(f) ` i) else 0)) ` x⟩)"

definition
  lepoll_assumptions15 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions15(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement
         (M, λy z. y ∈ inj⇗M⇖(if x ∈ range(f) then F(A, converse(f) ` x) else 0,K) ∧ z = {⟨x, y⟩})"

definition
  lepoll_assumptions16 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions16(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement(M, λx y. y = inj⇗M⇖(if x ∈ range(f) then F(A, converse(f) ` x) else 0,K))"

definition
  lepoll_assumptions17 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions17(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement
             (M, λx z. z = Sigfun(x, λi. inj⇗M⇖(if i ∈ range(f) then F(A, converse(f) ` i) else 0,K)))"

definition
  lepoll_assumptions18 :: "[i⇒o,i,[i,i]⇒i,i,i,i,i,i,i] ⇒ o" where
  "lepoll_assumptions18(M,A,F,S,fa,K,x,f,r) ≡ strong_replacement
         (M, λx y. y = ⟨x, minimum(r, inj⇗M⇖(if x ∈ range(f) then F(A, converse(f) ` x) else 0,K))⟩)"

lemmas lepoll_assumptions_defs[simp] = lepoll_assumptions1_def
  lepoll_assumptions2_def lepoll_assumptions3_def lepoll_assumptions4_def
  lepoll_assumptions5_def lepoll_assumptions6_def lepoll_assumptions7_def
  lepoll_assumptions8_def lepoll_assumptions9_def lepoll_assumptions10_def
  lepoll_assumptions11_def lepoll_assumptions12_def lepoll_assumptions13_def
  lepoll_assumptions14_def lepoll_assumptions15_def lepoll_assumptions16_def
  lepoll_assumptions17_def lepoll_assumptions18_def

definition if_range_F where
  [simp]: "if_range_F(H,f,i) ≡ if i ∈ range(f) then H(converse(f) ` i) else 0"

definition if_range_F_else_F where
  "if_range_F_else_F(H,b,f,i) ≡ if b=0 then if_range_F(H,f,i) else H(i)"

lemma (in M_basic) lam_Least_assumption_general:
  assumes
    separations:
    "∀A'[M]. separation(M, λy. ∃x∈A'. y = ⟨x, μ i. x ∈ if_range_F_else_F(F(A),b,f,i)⟩)"
    and
    mem_F_bound:"⋀x c. x∈F(A,c) ⟹ c ∈ range(f) ∪ U(A)"
    and
    types:"M(A)" "M(b)" "M(f)" "M(U(A))"
  shows "lam_replacement(M,λx . μ i. x ∈ if_range_F_else_F(F(A),b,f,i))"
proof -
  have "∀x∈X. (μ i. x ∈ if_range_F_else_F(F(A),b,f,i)) ∈
    Pow⇗M⇖(⋃(X ∪ range(f) ∪ U(A)))" if "M(X)" for X
  proof
    fix x
    assume "x∈X"
    moreover
    note ‹M(X)›
    moreover from calculation
    have "M(x)" by (auto dest:transM)
    moreover
    note assms
    ultimately
    show "(μ i. x ∈ if_range_F_else_F(F(A),b,f,i)) ∈
        Pow⇗M⇖(⋃(X ∪ range(f) ∪ U(A)))"
    proof (rule_tac Least_in_Pow_rel_Union, cases "b=0", simp_all)
      case True
      fix c
      assume asm:"x ∈ if_range_F_else_F(F(A), 0, f, c)"
      with mem_F_bound
      show "c∈X ∨ c ∈ range(f) ∨ c ∈ U(A)"
        unfolding if_range_F_else_F_def if_range_F_def by (cases "c∈range(f)") auto
    next
      case False
      fix c
      assume "x ∈ if_range_F_else_F(F(A), b, f, c)"
      with False mem_F_bound[of x c]
      show "c∈X ∨ c ∈ range(f) ∨ c∈U(A)"
        unfolding if_range_F_else_F_def if_range_F_def by auto
    qed
  qed
  with assms
  show ?thesis
    using bounded_lam_replacement[of "λx.(μ i. x ∈ if_range_F_else_F(F(A),b,f,i))"
        "λX. Pow⇗M⇖(⋃(X ∪ range(f) ∪ U(A)))"] by simp
qed

lemma (in M_basic) lam_Least_assumption_ifM_b0:
  fixes F
  defines "F ≡ λ_ x. if M(x) then x else 0"
  assumes
    separations:
    "∀A'[M]. separation(M, λy. ∃x∈A'. y = ⟨x, μ i. x ∈ if_range_F_else_F(F(A),0,f,i)⟩)"
    and
    types:"M(A)" "M(f)"
  shows "lam_replacement(M,λx . μ i. x ∈ if_range_F_else_F(F(A),0,f,i))"
    (is "lam_replacement(M,λx . Least(?P(x)))")
proof -
  {
    fix x X
    assume "M(X)" "x∈X" "(μ i. ?P(x,i)) ≠ 0"
    moreover from this
    obtain m where "Ord(m)" "?P(x,m)"
      using Least_0[of "?P(_)"] by auto
    moreover
    note assms
    moreover
    have "?P(x,i) ⟷ (M(converse(f) ` i) ∧ i ∈ range(f) ∧ x ∈ converse(f) ` i)"  for i
      unfolding F_def if_range_F_else_F_def if_range_F_def by auto
    ultimately
    have "(μ i. ?P(x,i)) ∈ range (f)"
      unfolding F_def if_range_F_else_F_def if_range_F_def
      by (rule_tac LeastI2) auto
  }
  with assms
  show ?thesis
    by (rule_tac bounded_lam_replacement[of _ "λX. range(f) ∪ {0}"]) auto
qed

lemma (in M_replacement_extra) lam_Least_assumption_ifM_bnot0:
  fixes F
  defines "F ≡ λ_ x. if M(x) then x else 0"
  assumes
    separations:
    "∀A'[M]. separation(M, λy. ∃x∈A'. y = ⟨x, μ i. x ∈ if_range_F_else_F(F(A),b,f,i)⟩)"
    "separation(M,Ord)"
    and
    types:"M(A)" "M(f)"
    and
    "b≠0"
  shows "lam_replacement(M,λx . μ i. x ∈ if_range_F_else_F(F(A),b,f,i))"
    (is "lam_replacement(M,λx . Least(?P(x)))")
proof -
  have "M(x) ⟹(μ i. (M(i) ⟶ x ∈ i) ∧ M(i)) = (if Ord(x) then succ(x) else 0)" for x
    using Ord_in_Ord
    apply (auto intro:Least_0, rule_tac Least_equality, simp_all)
    by (frule lt_Ord) (auto dest:le_imp_not_lt[of _ x] intro:ltI[of x])
  moreover
  have "lam_replacement(M, λx. if Ord(x) then succ(x) else 0)"
    using lam_replacement_if[OF _ _ separations(2)] lam_replacement_identity
      lam_replacement_constant lam_replacement_hcomp lam_replacement_succ
    by simp
  moreover
  note types ‹b≠0›
  ultimately
  show ?thesis
    using lam_replacement_cong
    unfolding F_def if_range_F_else_F_def if_range_F_def
    by auto
qed

lemma (in M_replacement_extra) lam_Least_assumption_drSR_Y:
  fixes F r' D
  defines "F ≡ drSR_Y(r',D)"
  assumes "∀A'[M]. separation(M, λy. ∃x∈A'. y = ⟨x, μ i. x ∈ if_range_F_else_F(F(A),b,f,i)⟩)"
    "M(A)" "M(b)" "M(f)" "M(r')"
  shows "lam_replacement(M,λx . μ i. x ∈ if_range_F_else_F(F(A),b,f,i))"
proof -
  from assms(2-)
  have [simp]: "M(X) ⟹ M(X ∪ range(f) ∪ {domain(x) . x ∈ A})"
    "M(r') ⟹ M(X) ⟹ M({restrict(x,r') . x ∈ A})"
    for X r'
    using lam_replacement_domain[THEN lam_replacement_imp_strong_replacement,
        THEN RepFun_closed, of A]
      lam_replacement_restrict'[THEN lam_replacement_imp_strong_replacement,
        THEN RepFun_closed, of r' A] by (auto dest:transM)
  have "∀x∈X. (μ i. x ∈ if_range_F_else_F(F(A),b,f,i)) ∈
    Pow⇗M⇖(⋃(X ∪ range(f) ∪ {domain(x). x∈A} ∪ {restrict(x,r'). x∈A} ∪ domain(A) ∪ range(A) ∪ ⋃A))" if "M(X)" for X
  proof
    fix x
    assume "x∈X"
    moreover
    note ‹M(X)›
    moreover from calculation
    have "M(x)" by (auto dest:transM)
    moreover
    note assms(2-)
    ultimately
    show "(μ i. x ∈ if_range_F_else_F(F(A),b,f,i)) ∈
        Pow⇗M⇖(⋃(X ∪ range(f) ∪ {domain(x). x∈A} ∪ {restrict(x,r'). x∈A} ∪ domain(A) ∪ range(A) ∪ ⋃A))"
      unfolding if_range_F_else_F_def if_range_F_def
    proof (rule_tac Least_in_Pow_rel_Union, simp_all,cases "b=0", simp_all)
      case True
      fix c
      assume asm:"x ∈ (if c ∈ range(f) then F(A, converse(f) ` c) else 0)"
      then
      show "c∈X ∨ c∈range(f) ∨ (∃x∈A. c = domain(x)) ∨ (∃x∈A. c = restrict(x,r')) ∨ c ∈ domain(A) ∨ c ∈ range(A) ∨ (∃x∈A. c∈x)" by auto
    next
      case False
      fix c
      assume "x ∈ F(A, c)"
      then
      show "c∈X ∨ c∈range(f) ∨ (∃x∈A. c = domain(x)) ∨ (∃x∈A. c = restrict(x,r')) ∨ c ∈ domain(A) ∨ c ∈ range(A) ∨ (∃x∈A. c∈x)"
        using apply_0
        by (cases "M(c)", auto simp:F_def drSR_Y_def dC_F_def)
    qed
  qed
  with assms(2-)
  show ?thesis
    using bounded_lam_replacement[of "λx.(μ i. x ∈ if_range_F_else_F(F(A),b,f,i))"
        "λX. Pow⇗M⇖(⋃(X ∪ range(f) ∪ {domain(x). x∈A} ∪ {restrict(x,r'). x∈A} ∪ domain(A) ∪ range(A) ∪ ⋃A))"] by simp
qed

locale M_replacement_lepoll = M_replacement_extra + M_inj +
  fixes F
  assumes
    F_type[simp]: "M(A) ⟹ ∀x[M]. M(F(A,x))"
    and
    lam_lepoll_assumption_F:"M(A) ⟹ lam_replacement(M,F(A))"
    and
    ― ‹Here b is a Boolean.›
    lam_Least_assumption:"M(A) ⟹ M(b) ⟹ M(f) ⟹
        lam_replacement(M,λx . μ i. x ∈ if_range_F_else_F(F(A),b,f,i))"
    and
    F_args_closed: "M(A) ⟹ M(x) ⟹ x ∈ F(A,i) ⟹ M(i)"
    and
    lam_replacement_inj_rel:"lam_replacement(M, λp. inj⇗M⇖(fst(p),snd(p)))"
begin

declare if_range_F_else_F_def[simp]

lemma lepoll_assumptions1:
  assumes types[simp]:"M(A)" "M(S)"
  shows "lepoll_assumptions1(M,A,F,S,fa,K,x,f,r)"
  using strong_replacement_separation[OF lam_replacement_sing_const_id separation_in_constant]
    transM[of _ S]
  by simp

lemma lepoll_assumptions2:
  assumes types[simp]:"M(A)" "M(S)"
  shows "lepoll_assumptions2(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_Sigfun lam_replacement_imp_strong_replacement
    assms lam_lepoll_assumption_F
  by simp

lemma lepoll_assumptions3:
  assumes types[simp]:"M(A)"
  shows "lepoll_assumptions3(M,A,F,S,fa,K,x,f,r)"
  using lam_lepoll_assumption_F[THEN lam_replacement_imp_strong_replacement]
  by simp

lemma lepoll_assumptions4:
  assumes types[simp]:"M(A)" "M(r)"
  shows "lepoll_assumptions4(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_minimum lam_replacement_constant lam_lepoll_assumption_F
  unfolding lepoll_assumptions_defs
    lam_replacement_def[symmetric]
  by (rule_tac lam_replacement_hcomp2[of _ _ minimum])
    (force intro: lam_replacement_identity)+

lemma lam_Least_closed :
  assumes "M(A)" "M(b)" "M(f)"
  shows "∀x[M]. M(μ i. x ∈ if_range_F_else_F(F(A),b,f,i))"
proof -
  have "x ∈ (if i ∈ range(f) then F(A, converse(f) ` i) else 0) ⟹ M(i)" for x i
  proof (cases "i∈range(f)")
    case True
    with ‹M(f)›
    show ?thesis by (auto dest:transM)
  next
    case False
    moreover
    assume "x ∈ (if i ∈ range(f) then F(A, converse(f) ` i) else 0)"
    ultimately
    show ?thesis
      by auto
  qed
  with assms
  show ?thesis
    using F_args_closed[of A] unfolding if_range_F_else_F_def if_range_F_def
    by (clarify, rule_tac Least_closed', cases "b=0") simp_all
qed

lemma lepoll_assumptions5:
  assumes
    types[simp]:"M(A)" "M(f)"
  shows "lepoll_assumptions5(M,A,F,S,fa,K,x,f,r)"
  using
    lam_replacement_apply2[THEN [5] lam_replacement_hcomp2]
    lam_replacement_hcomp[OF _ lam_replacement_apply[of f]]
    lam_replacement_identity
    lam_replacement_product lam_Least_closed[where b=1]
    assms lam_Least_assumption[where b=1,OF ‹M(A)› _ ‹M(f)›]
  unfolding lepoll_assumptions_defs
    lam_replacement_def[symmetric]
  by simp

lemma lepoll_assumptions6:
  assumes types[simp]:"M(A)" "M(S)" "M(x)"
  shows "lepoll_assumptions6(M,A,F,S,fa,K,x,f,r)"
  using strong_replacement_separation[OF lam_replacement_sing_const_id separation_in_constant]
    lam_replacement_inj_rel
  by simp

lemma lepoll_assumptions7:
  assumes types[simp]:"M(A)" "M(S)" "M(x)"
  shows "lepoll_assumptions7(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_constant lam_lepoll_assumption_F lam_replacement_inj_rel
  unfolding lepoll_assumptions_defs
  by (rule_tac lam_replacement_imp_strong_replacement)
    (rule_tac lam_replacement_hcomp2[of _ _ "inj_rel(M)"], simp_all)

lemma lepoll_assumptions8:
  assumes types[simp]:"M(A)" "M(S)"
  shows "lepoll_assumptions8(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_Sigfun lam_replacement_imp_strong_replacement
    lam_replacement_inj_rel lam_replacement_constant
    lam_replacement_hcomp2[of _ _ "inj_rel(M)",OF lam_lepoll_assumption_F[of A]]
  by simp

lemma lepoll_assumptions9:
  assumes types[simp]:"M(A)" "M(S)" "M(r)"
  shows "lepoll_assumptions9(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_minimum lam_replacement_constant lam_lepoll_assumption_F
    lam_replacement_hcomp2[of _ _ "inj_rel(M)"] lam_replacement_inj_rel lepoll_assumptions4
  unfolding lepoll_assumptions_defs lam_replacement_def[symmetric]
  by (rule_tac lam_replacement_hcomp2[of _ _ minimum])
    (force intro: lam_replacement_identity)+

lemma lepoll_assumptions10:
  assumes types[simp]:"M(A)" "M(f)"
  shows "lepoll_assumptions10(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_Sigfun lam_replacement_imp_strong_replacement
    lam_replacement_constant[OF nonempty]
    lam_replacement_if[OF _ _ separation_in_constant]
    lam_replacement_hcomp
    lam_replacement_apply[OF converse_closed[OF ‹M(f)›]]
    lam_lepoll_assumption_F[of A]
  by simp

lemma lepoll_assumptions11:
  assumes types[simp]:"M(A)" "M(f)"
  shows "lepoll_assumptions11(M, A, F, S, fa, K, x, f, r)"
  using lam_replacement_imp_strong_replacement
    lam_replacement_if[OF _ _ separation_in_constant[of "range(f)"]]
    lam_replacement_constant
    lam_replacement_hcomp lam_replacement_apply
    lam_lepoll_assumption_F
  by simp

lemma lepoll_assumptions12:
  assumes types[simp]:"M(A)" "M(x)" "M(f)"
  shows "lepoll_assumptions12(M,A,F,S,fa,K,x,f,r)"
  using strong_replacement_separation[OF lam_replacement_sing_const_id separation_in_constant]
  by simp

lemma lepoll_assumptions13:
  assumes types[simp]:"M(A)" "M(r)" "M(f)"
  shows "lepoll_assumptions13(M,A,F,S,fa,K,x,f,r)"
  using  lam_replacement_constant[OF nonempty] lam_lepoll_assumption_F
    lam_replacement_hcomp lam_replacement_apply
    lam_replacement_hcomp2[OF lam_replacement_constant[OF ‹M(r)›]
      lam_replacement_if[OF _ _ separation_in_constant[of "range(f)"]] _ _
      lam_replacement_minimum] assms
  unfolding lepoll_assumptions_defs
    lam_replacement_def[symmetric]
  by simp

lemma lepoll_assumptions14:
  assumes types[simp]:"M(A)" "M(f)" "M(fa)"
  shows "lepoll_assumptions14(M,A,F,S,fa,K,x,f,r)"
  using
    lam_replacement_apply2[THEN [5] lam_replacement_hcomp2]
    lam_replacement_hcomp[OF _ lam_replacement_apply[of fa]]
    lam_replacement_identity
    lam_replacement_product  lam_Least_closed[where b=0]
    assms lam_Least_assumption[where b=0,OF ‹M(A)› _ ‹M(f)›]
  unfolding lepoll_assumptions_defs
    lam_replacement_def[symmetric]
  by simp

lemma lepoll_assumptions15:
  assumes types[simp]:"M(A)" "M(x)" "M(f)" "M(K)"
  shows "lepoll_assumptions15(M,A,F,S,fa,K,x,f,r)"
  using strong_replacement_separation[OF lam_replacement_sing_const_id separation_in_constant]
  by simp

lemma lepoll_assumptions16:
  assumes types[simp]:"M(A)" "M(f)" "M(K)"
  shows "lepoll_assumptions16(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_imp_strong_replacement
    lam_replacement_inj_rel lam_replacement_constant
    lam_replacement_hcomp2[of _ _ "inj_rel(M)"]
    lam_replacement_constant[OF nonempty]
    lam_replacement_if[OF _ _ separation_in_constant]
    lam_replacement_hcomp
    lam_replacement_apply[OF converse_closed[OF ‹M(f)›]]
    lam_lepoll_assumption_F[of A]
  by simp

lemma lepoll_assumptions17:
  assumes types[simp]:"M(A)" "M(f)" "M(K)"
  shows "lepoll_assumptions17(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_Sigfun lam_replacement_imp_strong_replacement
    lam_replacement_inj_rel lam_replacement_constant
    lam_replacement_hcomp2[of _ _ "inj_rel(M)"]
    lam_replacement_constant[OF nonempty]
    lam_replacement_if[OF _ _ separation_in_constant]
    lam_replacement_hcomp
    lam_replacement_apply[OF converse_closed[OF ‹M(f)›]]
    lam_lepoll_assumption_F[of A]
  by simp

lemma lepoll_assumptions18:
  assumes types[simp]:"M(A)" "M(K)" "M(f)" "M(r)"
  shows "lepoll_assumptions18(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_constant lam_replacement_inj_rel lam_lepoll_assumption_F
    lam_replacement_minimum lam_replacement_identity lam_replacement_apply2 separation_in_constant
  unfolding lepoll_assumptions18_def lam_replacement_def[symmetric]
  by (rule_tac lam_replacement_hcomp2[of _ _ minimum], simp_all,
      rule_tac lam_replacement_hcomp2[of _ _ "inj_rel(M)"], simp_all)
    (rule_tac lam_replacement_if, rule_tac lam_replacement_hcomp[of _ "F(A)"],
      rule_tac lam_replacement_hcomp2[of _ _ "(`)"], simp_all)

lemmas lepoll_assumptions = lepoll_assumptions1 lepoll_assumptions2
  lepoll_assumptions3 lepoll_assumptions4 lepoll_assumptions5
  lepoll_assumptions6 lepoll_assumptions7 lepoll_assumptions8
  lepoll_assumptions9 lepoll_assumptions10 lepoll_assumptions11
  lepoll_assumptions12 lepoll_assumptions13 lepoll_assumptions14
  lepoll_assumptions15 lepoll_assumptions16
  lepoll_assumptions17 lepoll_assumptions18

end ― ‹locale‹M_replacement_lepoll››

end

Theory Cardinal_Library_Relative

section‹Cardinal Arithmetic under Choice\label{sec:cardinal-lib-rel}›

theory Cardinal_Library_Relative
  imports
    Replacement_Lepoll
begin

locale M_library = M_ZF_library + M_cardinal_AC +
  assumes
    separation_cardinal_rel_lesspoll_rel: "M(κ) ⟹ separation(M, λx . x ≺⇗M⇖ κ)"
begin

declare eqpoll_rel_refl [simp]

subsection‹Miscellaneous›

lemma cardinal_rel_RepFun_apply_le:
  assumes "S ∈ A→B" "M(S)" "M(A)" "M(B)"
  shows "|{S`a . a∈A}|⇗M⇖ ≤ |A|⇗M⇖"
proof -
  note assms
  moreover from this
  have "{S ` a . a ∈ A} = S``A"
    using image_eq_UN RepFun_def UN_iff by force
  moreover from calculation
  have "M(λx∈A. S ` x)" "M({S ` a . a ∈ A})"
    using lam_closed[of "λ x. S`x"] apply_type[OF ‹S∈_›]
      transM[OF _ ‹M(B)›] image_closed
    by auto
  moreover from assms this
  have "(λx∈A. S`x) ∈ surj_rel(M,A, {S`a . a∈A})"
    using mem_surj_abs lam_funtype[of A "λx . S`x"]
    unfolding surj_def by auto
  ultimately
  show ?thesis
    using surj_rel_char surj_rel_implies_cardinal_rel_le by simp
qed

(* TODO: Check if we can use this lemma to prove the previous one and
    not the other way around *)
lemma cardinal_rel_RepFun_le:
  assumes lrf:"lam_replacement(M,f)" and f_closed:"∀x[M]. M(f(x))" and "M(X)"
  shows "|{f(x) . x ∈ X}|⇗M⇖ ≤ |X|⇗M⇖"
  using ‹M(X)› f_closed cardinal_rel_RepFun_apply_le[OF lam_funtype, of X _, OF
      lrf[THEN [2] lam_replacement_iff_lam_closed[THEN iffD1, THEN rspec]]]
    lrf[THEN lam_replacement_imp_strong_replacement]
  by simp (auto simp flip:setclass_iff intro!:RepFun_closed dest:transM)

lemma subset_imp_le_cardinal_rel: "A ⊆ B ⟹ M(A) ⟹ M(B) ⟹ |A|⇗M⇖ ≤ |B|⇗M⇖"
  using subset_imp_lepoll_rel[THEN lepoll_rel_imp_cardinal_rel_le] .

lemma lt_cardinal_rel_imp_not_subset: "|A|⇗M⇖ < |B|⇗M⇖ ⟹ M(A) ⟹ M(B) ⟹ ¬ B ⊆ A"
  using subset_imp_le_cardinal_rel le_imp_not_lt  by blast

lemma cardinal_rel_lt_csucc_rel_iff:
  "Card_rel(M,K) ⟹ M(K) ⟹ M(K') ⟹ |K'|⇗M⇖ < (K+)⇗M⇖ ⟷ |K'|⇗M⇖ ≤ K"
  by (simp add: Card_rel_lt_csucc_rel_iff)

end ― ‹locale‹M_library››

locale M_cardinal_UN_nat = M_cardinal_UN _ ω X for X
begin
lemma cardinal_rel_UN_le_nat:
  assumes "⋀i. i∈ω ⟹ |X(i)|⇗M⇖ ≤ ω"
  shows "|⋃i∈ω. X(i)|⇗M⇖ ≤ ω"
proof -
  from assms
  show ?thesis
    by (simp add: cardinal_rel_UN_le InfCard_rel_nat)
qed

end ― ‹locale‹M_cardinal_UN_nat››

locale M_cardinal_UN_inj = M_library +
  j:M_cardinal_UN _ J +
  y:M_cardinal_UN _ K "λk. if k∈range(f) then X(converse(f)`k) else 0" for J K f +
assumes
  f_inj: "f ∈ inj_rel(M,J,K)"
begin

lemma inj_rel_imp_cardinal_rel_UN_le:
  notes [dest] = InfCard_is_Card Card_is_Ord
  fixes Y
  defines "Y(k) ≡ if k∈range(f) then X(converse(f)`k) else 0"
  assumes "InfCard⇗M⇖(K)" "⋀i. i∈J ⟹ |X(i)|⇗M⇖ ≤ K"
  shows "|⋃i∈J. X(i)|⇗M⇖ ≤ K"
proof -
  have "M(K)" "M(J)" "⋀w x. w ∈ X(x) ⟹ M(x)"
    using y.Pi_assumptions j.Pi_assumptions j.X_witness_in_M by simp_all
  then
  have "M(f)"
    using inj_rel_char f_inj by simp
  note inM = ‹M(f)› ‹M(K)› ‹M(J)› ‹⋀w x. w ∈ X(x) ⟹ M(x)›
  have "i∈J ⟹ f`i ∈ K" for i
    using inj_rel_is_fun[OF f_inj] apply_type
      function_space_rel_char by (auto simp add:inM)
  have "(⋃i∈J. X(i)) ⊆ (⋃i∈K. Y(i))"
  proof (standard, elim UN_E)
    fix x i
    assume "i∈J" "x∈X(i)"
    with ‹i∈J ⟹ f`i ∈ K›
    have "x ∈ Y(f`i)" "f`i ∈ K"
      unfolding Y_def
      using inj_is_fun right_inverse f_inj
      by (auto simp add:inM Y_def intro: apply_rangeI)
    then
    show "x ∈ (⋃i∈K. Y(i))" by auto
  qed
  then
  have "|⋃i∈J. X(i)|⇗M⇖ ≤ |⋃i∈K. Y(i)|⇗M⇖"
    using subset_imp_le_cardinal_rel j.UN_closed y.UN_closed
    unfolding Y_def by (simp add:inM)
  moreover
  note assms ‹⋀i. i∈J ⟹ f`i ∈ K› inM
  moreover from this
  have "k∈range(f) ⟹ converse(f)`k ∈ J" for k
    using inj_rel_converse_fun[OF f_inj]
      range_fun_subset_codomain function_space_rel_char by simp
  ultimately
  show "|⋃i∈J. X(i)|⇗M⇖ ≤ K"
    using InfCard_rel_is_Card_rel[THEN Card_rel_is_Ord,THEN Ord_0_le, of K]
    by (rule_tac le_trans[OF _ y.cardinal_rel_UN_le])
      (auto intro:Ord_0_le simp:Y_def)+
qed

end ― ‹locale‹M_cardinal_UN_inj››

locale M_cardinal_UN_lepoll = M_library + M_replacement_lepoll _ "λ_. X" +
  j:M_cardinal_UN _ J for J
begin

(* FIXME: this "LEQpoll" should be "LEPOLL"; same correction in Delta System *)
lemma leqpoll_rel_imp_cardinal_rel_UN_le:
  notes [dest] = InfCard_is_Card Card_is_Ord
  assumes "InfCard⇗M⇖(K)" "J ≲⇗M⇖ K" "⋀i. i∈J ⟹ |X(i)|⇗M⇖ ≤ K"
    "M(K)"
  shows "|⋃i∈J. X(i)|⇗M⇖ ≤ K"
proof -
  from ‹J ≲⇗M⇖ K›
  obtain f where "f ∈ inj_rel(M,J,K)" "M(f)" by blast
  moreover
  let ?Y="λk. if k∈range(f) then X(converse(f)`k) else 0"
  note ‹M(K)›
  moreover from calculation
  have "k ∈ range(f) ⟹ converse(f)`k ∈ J" for k
    using mem_inj_rel[THEN inj_converse_fun, THEN apply_type]
      j.Pi_assumptions by blast
  moreover from ‹M(f)›
  have "w ∈ ?Y(x) ⟹ M(x)" for w x
    by (cases "x∈range(f)") (auto dest:transM)
  moreover from calculation
  interpret M_Pi_assumptions_choice _ K ?Y
    using j.Pi_assumptions lepoll_assumptions
  proof (unfold_locales, auto dest:transM)
    show "strong_replacement(M, λy z. False)"
      unfolding strong_replacement_def by auto
  qed
  from calculation
  interpret M_cardinal_UN_inj _ _ _ _ f
    using lepoll_assumptions
    by unfold_locales auto
  from assms
  show ?thesis using inj_rel_imp_cardinal_rel_UN_le by simp
qed

end ― ‹locale‹M_cardinal_UN_lepoll››

context M_library
begin

lemma cardinal_rel_lt_csucc_rel_iff':
  includes Ord_dests
  assumes "Card_rel(M,κ)"
    and types:"M(κ)" "M(X)"
  shows "κ < |X|⇗M⇖ ⟷ (κ+)⇗M⇖ ≤ |X|⇗M⇖"
  using assms cardinal_rel_lt_csucc_rel_iff[of κ X] Card_rel_csucc_rel[of κ]
    not_le_iff_lt[of "(κ+)⇗M⇖" "|X|⇗M⇖"] not_le_iff_lt[of "|X|⇗M⇖" κ]
  by blast

lemma lepoll_rel_imp_subset_bij_rel:
  assumes "M(X)" "M(Y)"
  shows "X ≲⇗M⇖ Y ⟷ (∃Z[M]. Z ⊆ Y ∧ Z ≈⇗M⇖ X)"
proof
  assume "X ≲⇗M⇖ Y"
  then
  obtain j where  "j ∈ inj_rel(M,X,Y)"
    by blast
  with assms
  have "range(j) ⊆ Y" "j ∈ bij_rel(M,X,range(j))" "M(range(j))" "M(j)"
    using inj_rel_bij_rel_range inj_rel_char
      inj_rel_is_fun[THEN range_fun_subset_codomain,of j X Y]
    by auto
  with assms
  have "range(j) ⊆ Y" "X ≈⇗M⇖ range(j)"
    unfolding eqpoll_rel_def by auto
  with assms ‹M(j)›
  show "∃Z[M]. Z ⊆ Y ∧ Z ≈⇗M⇖ X"
    using eqpoll_rel_sym[OF ‹X ≈⇗M⇖ range(j)›]
    by auto
next
  assume "∃Z[M]. Z ⊆ Y ∧ Z ≈⇗M⇖ X"
  then
  obtain Z f where "f ∈ bij_rel(M,Z,X)" "Z ⊆ Y" "M(Z)" "M(f)"
    unfolding eqpoll_rel_def by blast
  with assms
  have "converse(f) ∈ inj_rel(M,X,Y)" "M(converse(f))"
    using inj_rel_weaken_type[OF bij_rel_converse_bij_rel[THEN bij_rel_is_inj_rel],of f Z X Y]
    by auto
  then
  show "X ≲⇗M⇖ Y"
    unfolding lepoll_rel_def by auto
qed

text‹The following result proves to be very useful when combining
     term‹cardinal_rel› and term‹eqpoll_rel› in a calculation.›

lemma cardinal_rel_Card_rel_eqpoll_rel_iff:
  "Card_rel(M,κ) ⟹ M(κ) ⟹ M(X) ⟹ |X|⇗M⇖ = κ ⟷ X ≈⇗M⇖ κ"
  using Card_rel_cardinal_rel_eq[of κ] cardinal_rel_eqpoll_rel_iff[of X κ] by auto

lemma lepoll_rel_imp_lepoll_rel_cardinal_rel:
  assumes"X ≲⇗M⇖ Y"  "M(X)" "M(Y)"
  shows "X ≲⇗M⇖ |Y|⇗M⇖"
  using assms cardinal_rel_Card_rel_eqpoll_rel_iff[of "|Y|⇗M⇖" Y]
    Card_rel_cardinal_rel
    lepoll_rel_eq_trans[of _ _ "|Y|⇗M⇖"] by simp

lemma lepoll_rel_Un:
  assumes "InfCard_rel(M,κ)" "A ≲⇗M⇖ κ" "B ≲⇗M⇖ κ" "M(A)" "M(B)" "M(κ)"
  shows "A ∪ B ≲⇗M⇖ κ"
proof -
  from assms
  have "A ∪ B ≲⇗M⇖ sum(A,B)"
    using Un_lepoll_rel_sum by simp
  moreover
  note assms
  moreover from this
  have "|sum(A,B)|⇗M⇖ ≤ κ ⊕⇗M⇖ κ"
    using sum_lepoll_rel_mono[of A κ B κ] lepoll_rel_imp_cardinal_rel_le
    unfolding cadd_rel_def by auto
  ultimately
  show ?thesis
    using InfCard_rel_cdouble_eq Card_rel_cardinal_rel_eq
      InfCard_rel_is_Card_rel Card_rel_le_imp_lepoll_rel[of "sum(A,B)" κ]
      lepoll_rel_trans[of "A∪B"]
    by auto
qed

lemma cardinal_rel_Un_le:
  assumes "InfCard_rel(M,κ)" "|A|⇗M⇖ ≤ κ" "|B|⇗M⇖ ≤ κ" "M(κ)" "M(A)" "M(B)"
  shows "|A ∪ B|⇗M⇖ ≤ κ"
  using assms lepoll_rel_Un le_Card_rel_iff InfCard_rel_is_Card_rel by auto

lemma Finite_cardinal_rel_iff': "M(i) ⟹ Finite(|i|⇗M⇖) ⟷ Finite(i)"
  using eqpoll_rel_imp_Finite_iff[OF cardinal_rel_eqpoll_rel]
  by auto

lemma cardinal_rel_subset_of_Card_rel:
  assumes "Card_rel(M,γ)" "a ⊆ γ" "M(a)" "M(γ)"
  shows "|a|⇗M⇖ < γ ∨ |a|⇗M⇖ = γ"
proof -
  from assms
  have "|a|⇗M⇖ < |γ|⇗M⇖ ∨ |a|⇗M⇖ = |γ|⇗M⇖"
    using subset_imp_le_cardinal_rel[THEN le_iff[THEN iffD1]] by simp
  with assms
  show ?thesis
    using Card_rel_cardinal_rel_eq by auto
qed

lemma cardinal_rel_cases:
  includes Ord_dests
  assumes "M(γ)" "M(X)"
  shows "Card_rel(M,γ) ⟹ |X|⇗M⇖ < γ ⟷ ¬ |X|⇗M⇖ ≥ γ"
  using assms not_le_iff_lt Card_rel_is_Ord Ord_cardinal_rel
  by auto

end ― ‹locale‹M_library››

subsection‹Countable and uncountable sets›

definition (* FIXME: From Cardinal_Library, on the context of AC *)
  countable :: "i⇒o" where
  "countable(X) ≡ X ≲ ω"

relativize functional "countable" "countable_rel" external
relationalize "countable_rel" "is_countable"

notation countable_rel (‹countable⇗_⇖'(_')›)

abbreviation
  countable_r_set  :: "[i,i]⇒o"  (‹countable⇗_⇖'(_')›) where
  "countable⇗M⇖(i) ≡ countable_rel(##M,i)"

context M_library
begin

lemma countableI[intro]: "X ≲⇗M⇖ ω ⟹ countable_rel(M,X)"
  unfolding countable_rel_def by simp

lemma countableD[dest]: "countable_rel(M,X) ⟹ X ≲⇗M⇖ ω"
  unfolding countable_rel_def by simp

lemma countable_rel_iff_cardinal_rel_le_nat: "M(X) ⟹ countable_rel(M,X) ⟷ |X|⇗M⇖ ≤ ω"
  using le_Card_rel_iff[of ω X] Card_rel_nat
  unfolding countable_rel_def by simp

lemma lepoll_rel_countable_rel: "X ≲⇗M⇖ Y ⟹ countable_rel(M,Y) ⟹ M(X) ⟹ M(Y) ⟹ countable_rel(M,X)"
  using lepoll_rel_trans[of X Y] by blast

― ‹Next lemma can be proved without using AC›
lemma surj_rel_countable_rel:
  "countable_rel(M,X) ⟹ f ∈ surj_rel(M,X,Y) ⟹ M(X) ⟹ M(Y) ⟹ M(f) ⟹ countable_rel(M,Y)"
  using surj_rel_implies_cardinal_rel_le[of f X Y, THEN le_trans]
    countable_rel_iff_cardinal_rel_le_nat by simp

lemma Finite_imp_countable_rel: "Finite_rel(M,X) ⟹ M(X) ⟹ countable_rel(M,X)"
  unfolding Finite_rel_def
  by (auto intro:InfCard_rel_nat nats_le_InfCard_rel[of _ ω,
        THEN le_imp_lepoll_rel] dest!:eq_lepoll_rel_trans[of X _ ω] )

end ― ‹locale‹M_library››

lemma (in M_cardinal_UN_lepoll) countable_rel_imp_countable_rel_UN:
  assumes "countable_rel(M,J)" "⋀i. i∈J ⟹ countable_rel(M,X(i))"
  shows "countable_rel(M,⋃i∈J. X(i))"
  using assms leqpoll_rel_imp_cardinal_rel_UN_le[of ω] InfCard_rel_nat
    InfCard_rel_is_Card_rel j.UN_closed
    countable_rel_iff_cardinal_rel_le_nat j.Pi_assumptions
    Card_rel_le_imp_lepoll_rel[of J ω] Card_rel_cardinal_rel_eq[of ω]
  by auto

locale M_cardinal_library = M_library + M_replacement +
  assumes
    lam_replacement_inj_rel:"lam_replacement(M, λx. inj⇗M⇖(fst(x),snd(x)))"
    and
    cdlt_assms: "M(G) ⟹ M(Q) ⟹ separation(M, λp. ∀x∈G. x ∈ snd(p) ⟷ (∀s∈fst(p). ⟨s, x⟩ ∈ Q))"
    and
    cardinal_lib_assms1:
    "M(A) ⟹ M(b) ⟹ M(f) ⟹
       separation(M, λy. ∃x∈A. y = ⟨x, μ i. x ∈ if_range_F_else_F(λx. if M(x) then x else 0,b,f,i)⟩)"
    and
    cardinal_lib_assms2:
    "M(A') ⟹ M(G) ⟹ M(b) ⟹ M(f) ⟹
        separation(M, λy. ∃x∈A'. y = ⟨x, μ i. x ∈ if_range_F_else_F(λa. if M(a) then G`a else 0,b,f,i)⟩)"
    and
    cardinal_lib_assms3:
    "M(A') ⟹ M(b) ⟹ M(f) ⟹ M(F) ⟹
        separation(M, λy. ∃x∈A'. y = ⟨x, μ i. x ∈ if_range_F_else_F(λa. if M(a) then F-``{a} else 0,b,f,i)⟩)"
    and
    lam_replacement_cardinal_rel : "lam_replacement(M, cardinal_rel(M))"
    and
    cardinal_lib_assms6:
    "M(f) ⟹ M(β) ⟹ Ord(β) ⟹
      strong_replacement(M, λx y. x∈β ∧ y = ⟨x, transrec(x, λa g. f ` (g `` a))⟩)"

begin

lemma cardinal_lib_assms5 :
  "M(γ) ⟹ Ord(γ) ⟹ separation(M, λZ . cardinal_rel(M,Z) < γ)"
  unfolding lt_def
  using separation_in lam_replacement_constant[of γ] separation_univ lam_replacement_cardinal_rel
  unfolding lt_def
  by simp_all

lemma separation_dist: "separation(M, λ x . ∃a. ∃b . x=⟨a,b⟩ ∧ a≠b)"
  using separation_pair separation_neg separation_eq lam_replacement_fst lam_replacement_snd
  by simp

lemma cdlt_assms': "M(x) ⟹ M(Q) ⟹ separation(M, λa .  ∀s∈x. ⟨s, a⟩ ∈ Q)"
  using separation_in[OF _
      lam_replacement_hcomp2[OF _ _ _ _ lam_replacement_Pair] _
      lam_replacement_constant]
    separation_ball lam_replacement_hcomp lam_replacement_fst lam_replacement_snd
  by simp_all

lemma countable_rel_union_countable_rel:
  assumes "⋀x. x ∈ C ⟹ countable_rel(M,x)" "countable_rel(M,C)" "M(C)"
  shows "countable_rel(M,⋃C)"
proof -
  have "x ∈ (if M(i) then i else 0) ⟹ M(i)" for x i
    by (cases "M(i)") auto
  then
  interpret M_replacement_lepoll M "λ_ x. if M(x) then x else 0"
    using  lam_replacement_if[OF lam_replacement_identity
        lam_replacement_constant[OF nonempty], where b=M] lam_replacement_inj_rel
  proof(unfold_locales,auto simp add: separation_def)
    fix b f
    assume "M(b)" "M(f)"
    show "lam_replacement(M, λx. μ i. x ∈ if_range_F_else_F(λx. if M(x) then x else 0, b, f, i))"
    proof (cases "b=0")
      case True
      with ‹M(f)›
      show ?thesis
        using cardinal_lib_assms1
        by (simp_all; rule_tac lam_Least_assumption_ifM_b0)+
    next
      case False
      with ‹M(f)› ‹M(b)›
      show ?thesis
        using cardinal_lib_assms1 separation_Ord
        by (rule_tac lam_Least_assumption_ifM_bnot0) auto
    qed
  qed
  note ‹M(C)›
  moreover
  have  "w ∈ (if M(x) then x else 0) ⟹ M(x)" for w x
    by (cases "M(x)") auto
  ultimately
  interpret M_cardinal_UN_lepoll _ "λc. if M(c) then c else 0" C
    using lepoll_assumptions
    by unfold_locales simp_all
  have "(if M(i) then i else 0) = i" if "i∈C" for i
    using transM[OF _ ‹M(C)›] that by simp
  then
  show ?thesis
    using assms countable_rel_imp_countable_rel_UN by simp
qed

end ― ‹locale‹M_cardinal_library››

abbreviation
  uncountable_rel :: "[i⇒o,i]⇒o" where
  "uncountable_rel(M,X) ≡ ¬ countable_rel(M,X)"

context M_cardinal_library
begin

lemma uncountable_rel_iff_nat_lt_cardinal_rel:
  "M(X) ⟹ uncountable_rel(M,X) ⟷ ω < |X|⇗M⇖"
  using countable_rel_iff_cardinal_rel_le_nat not_le_iff_lt by simp

lemma uncountable_rel_not_empty: "uncountable_rel(M,X) ⟹ X ≠ 0"
  using empty_lepoll_relI by auto

lemma uncountable_rel_imp_Infinite: "uncountable_rel(M,X) ⟹ M(X) ⟹ Infinite(X)"
  using uncountable_rel_iff_nat_lt_cardinal_rel[of X] lepoll_rel_nat_imp_Infinite[of X]
    cardinal_rel_le_imp_lepoll_rel[of ω X] leI
  by simp

lemma uncountable_rel_not_subset_countable_rel:
  assumes "countable_rel(M,X)" "uncountable_rel(M,Y)" "M(X)" "M(Y)"
  shows "¬ (Y ⊆ X)"
  using assms lepoll_rel_trans subset_imp_lepoll_rel[of Y X]
  by blast


subsection‹Results on Aleph\_rels›

lemma nat_lt_Aleph_rel1: "ω < ℵ⇘1⇙⇗M⇖"
  by (simp add: Aleph_rel_succ Aleph_rel_zero lt_csucc_rel)

lemma zero_lt_Aleph_rel1: "0 < ℵ⇘1⇙⇗M⇖"
  by (rule lt_trans[of _ "ω"], auto simp add: ltI nat_lt_Aleph_rel1)

lemma le_Aleph_rel1_nat: "M(k) ⟹ Card_rel(M,k) ⟹ k<ℵ⇘1⇙⇗M⇖ ⟹ k ≤ ω"
  by (simp add: Aleph_rel_succ Aleph_rel_zero Card_rel_lt_csucc_rel_iff Card_rel_nat)

lemma lesspoll_rel_Aleph_rel_succ:
  assumes "Ord(α)"
    and types:"M(α)" "M(d)"
  shows "d ≺⇗M⇖ ℵ⇘succ(α)⇙⇗M⇖ ⟷ d ≲⇗M⇖ ℵ⇘α⇙⇗M⇖"
  using assms Aleph_rel_succ Card_rel_is_Ord Ord_Aleph_rel lesspoll_rel_csucc_rel
  by simp

lemma cardinal_rel_Aleph_rel [simp]: "Ord(α) ⟹ M(α) ⟹ |ℵ⇘α⇙⇗M⇖|⇗M⇖ = ℵ⇘α⇙⇗M⇖"
  using Card_rel_cardinal_rel_eq by simp

― ‹Could be proved without using AC›
lemma Aleph_rel_lesspoll_rel_increasing:
  includes Aleph_rel_intros
  assumes "M(b)" "M(a)"
  shows "a < b ⟹ ℵ⇘a⇙⇗M⇖ ≺⇗M⇖ ℵ⇘b⇙⇗M⇖"
  using assms
    cardinal_rel_lt_iff_lesspoll_rel[of "ℵ⇘a⇙⇗M⇖" "ℵ⇘b⇙⇗M⇖"]
    Aleph_rel_increasing[of a b] Card_rel_cardinal_rel_eq[of "ℵ⇘b⇙"]
    lt_Ord lt_Ord2 Card_rel_Aleph_rel[THEN Card_rel_is_Ord]
  by auto

lemma uncountable_rel_iff_subset_eqpoll_rel_Aleph_rel1:
  includes Ord_dests
  assumes "M(X)"
  notes Aleph_rel_zero[simp] Card_rel_nat[simp] Aleph_rel_succ[simp]
  shows "uncountable_rel(M,X) ⟷ (∃S[M]. S ⊆ X ∧ S ≈⇗M⇖ ℵ⇘1⇙⇗M⇖)"
proof
  assume "uncountable_rel(M,X)"
  with ‹M(X)›
  have "ℵ⇘1⇙⇗M⇖ ≲⇗M⇖ X"
    using uncountable_rel_iff_nat_lt_cardinal_rel cardinal_rel_lt_csucc_rel_iff'
      cardinal_rel_le_imp_lepoll_rel by auto
  with ‹M(X)›
  obtain S where "M(S)" "S ⊆ X" "S ≈⇗M⇖ ℵ⇘1⇙⇗M⇖"
    using lepoll_rel_imp_subset_bij_rel by auto
  then
  show "∃S[M]. S ⊆ X ∧ S ≈⇗M⇖ ℵ⇘1⇙⇗M⇖"
    using cardinal_rel_cong Card_rel_csucc_rel[of ω] Card_rel_cardinal_rel_eq by auto
next
  note Aleph_rel_lesspoll_rel_increasing[of 1 0,simplified]
  assume "∃S[M]. S ⊆ X ∧ S ≈⇗M⇖ ℵ⇘1⇙⇗M⇖"
  moreover
  have eq:"ℵ⇘1⇙⇗M⇖ = (ω+)⇗M⇖" by auto
  moreover from calculation ‹M(X)›
  have A:"(ω+)⇗M⇖ ≲⇗M⇖ X"
    using subset_imp_lepoll_rel[THEN [2] eq_lepoll_rel_trans, of "ℵ⇘1⇙⇗M⇖" _ X,
        OF eqpoll_rel_sym] by auto
  with ‹M(X)›
  show "uncountable_rel(M,X)"
    using
      lesspoll_rel_trans1[OF lepoll_rel_trans[OF A _] ‹ω ≺⇗M⇖ (ω+)⇗M⇖›]
      lesspoll_rel_not_refl
    by auto
qed

lemma UN_if_zero: "M(K) ⟹ (⋃x∈K. if M(x) then G ` x else 0) =(⋃x∈K. G ` x)"
  using transM[of _ K] by auto

lemma mem_F_bound1:
  fixes F G
  defines "F ≡ λ_ x. if M(x) then G`x else 0"
  shows "x∈F(A,c) ⟹ c ∈ (range(f) ∪ domain(G) )"
  using apply_0 unfolding F_def
  by (cases "M(c)", auto simp:F_def drSR_Y_def dC_F_def)

lemma lt_Aleph_rel_imp_cardinal_rel_UN_le_nat: "function(G) ⟹ domain(G) ≲⇗M⇖ ω ⟹
   ∀n∈domain(G). |G`n|⇗M⇖<ℵ⇘1⇙⇗M⇖ ⟹ M(G) ⟹ |⋃n∈domain(G). G`n|⇗M⇖≤ω"
proof -
  assume "M(G)"
  moreover from this
  have "x ∈ (if M(i) then G ` i else 0) ⟹ M(i)" for x i
    by (cases "M(i)") auto
  moreover
  have "separation(M, M)" unfolding separation_def by auto
  ultimately
  interpret M_replacement_lepoll M "λ_ x. if M(x) then G`x else 0"
    using lam_replacement_inj_rel cardinal_lib_assms2 mem_F_bound1[of _ _ G]
      lam_if_then_replacement_apply
    by (unfold_locales, simp_all)
      (rule lam_Least_assumption_general[where U="λ_. domain(G)"], auto)
  note ‹M(G)›
  moreover
  have  "w ∈ (if M(x) then G ` x else 0) ⟹ M(x)" for w x
    by (cases "M(x)") auto
  ultimately
  interpret M_cardinal_UN_lepoll _  "λn. if M(n) then G`n else 0" "domain(G)"
    using lepoll_assumptions1[where S="domain(G)",unfolded lepoll_assumptions1_def]
      cardinal_lib_assms2 lepoll_assumptions
    by (unfold_locales, auto)
  assume "function(G)"
  let ?N="domain(G)" and ?R="⋃n∈domain(G). G`n"
  assume "?N ≲⇗M⇖ ω"
  assume Eq1: "∀n∈?N. |G`n|⇗M⇖<ℵ⇘1⇙⇗M⇖"
  {
    fix n
    assume "n∈?N"
    with Eq1 ‹M(G)›
    have "|G`n|⇗M⇖ ≤ ω"
      using le_Aleph_rel1_nat[of "|G ` n|⇗M⇖"] leqpoll_rel_imp_cardinal_rel_UN_le
        UN_if_zero[of "domain(G)" G]
      by (auto dest:transM)
  }
  then
  have "n∈?N ⟹ |G`n|⇗M⇖ ≤ ω" for n .
  moreover
  note ‹?N ≲⇗M⇖ ω› ‹M(G)›
  moreover
  have "(if M(i) then G ` i else 0) ⊆ G ` i" for i
    by auto
  with ‹M(G)›
  have "|if M(i) then G ` i else 0|⇗M⇖ ≤ |G ` i|⇗M⇖" for i
  proof(cases "M(i)")
    case True
    with ‹M(G)› show ?thesis using Ord_cardinal_rel[OF apply_closed]
      by simp
  next
    case False
    then
    have "i∉domain(G)"
      using transM[OF _ domain_closed[OF ‹M(G)›]] by auto
    then
    show ?thesis
      using Ord_cardinal_rel[OF apply_closed] apply_0 by simp
  qed
  ultimately
  show ?thesis
    using InfCard_rel_nat leqpoll_rel_imp_cardinal_rel_UN_le[of ω]
      UN_if_zero[of "domain(G)" G]
      le_trans[of "|if M(_) then G ` _ else 0|⇗M⇖" "|G ` _|⇗M⇖" ω]
    by auto blast
qed

lemma Aleph_rel1_eq_cardinal_rel_vimage: "f:ℵ⇘1⇙⇗M⇖→⇗M⇖ω ⟹ ∃n∈ω. |f-``{n}|⇗M⇖ = ℵ⇘1⇙⇗M⇖"
proof -
  assume "f:ℵ⇘1⇙⇗M⇖→⇗M⇖ω"
  then
  have "function(f)" "domain(f) = ℵ⇘1⇙⇗M⇖" "range(f)⊆ω" "f∈ℵ⇘1⇙⇗M⇖→ω" "M(f)"
    using mem_function_space_rel[OF ‹f∈_›] domain_of_fun fun_is_function range_fun_subset_codomain
      function_space_rel_char
    by auto
  let ?G="λn∈range(f). f-``{n}"
  from ‹f:ℵ⇘1⇙⇗M⇖→ω›
  have "range(f) ⊆ ω" "domain(?G) = range(f)"
    using range_fun_subset_codomain
    by simp_all
  from ‹f:ℵ⇘1⇙⇗M⇖→ω› ‹M(f)› ‹range(f) ⊆ ω›
  have "M(f-``{n})" if "n ∈ range(f)" for n
    using that transM[of _ ω] by auto
  with ‹M(f)› ‹range(f) ⊆ ω›
  have "domain(?G) ≲⇗M⇖ ω" "M(?G)"
    using subset_imp_lepoll_rel lam_closed[of "λx . f-``{x}"] cardinal_lib_assms4
    by simp_all
  have "function(?G)" by (simp add:function_lam)
  from ‹f:ℵ⇘1⇙⇗M⇖→ω›
  have "n∈ω ⟹ f-``{n} ⊆ ℵ⇘1⇙⇗M⇖" for n
    using Pi_vimage_subset by simp
  with ‹range(f) ⊆ ω›
  have "ℵ⇘1⇙⇗M⇖ = (⋃n∈range(f). f-``{n})"
  proof (intro equalityI, intro subsetI)
    fix x
    assume "x ∈ ℵ⇘1⇙⇗M⇖"
    with ‹f:ℵ⇘1⇙⇗M⇖→ω› ‹function(f)› ‹domain(f) = ℵ⇘1⇙⇗M⇖›
    have "x ∈ f-``{f`x}" "f`x ∈ range(f)"
      using function_apply_Pair vimage_iff apply_rangeI by simp_all
    then
    show "x ∈ (⋃n∈range(f). f-``{n})" by auto
  qed auto
  {
    assume "∀n∈range(f). |f-``{n}|⇗M⇖ < ℵ⇘1⇙⇗M⇖"
    then
    have "∀n∈domain(?G). |?G`n|⇗M⇖ < ℵ⇘1⇙⇗M⇖"
      using zero_lt_Aleph_rel1 by (auto)
    with ‹function(?G)› ‹domain(?G) ≲⇗M⇖ ω› ‹M(?G)›
    have "|⋃n∈domain(?G). ?G`n|⇗M⇖≤ω"
      using lt_Aleph_rel_imp_cardinal_rel_UN_le_nat[of ?G]
      by auto
    then
    have "|⋃n∈range(f). f-``{n}|⇗M⇖≤ω" by simp
    with ‹ℵ⇘1⇙⇗M⇖ = _›
    have "|ℵ⇘1⇙⇗M⇖|⇗M⇖ ≤ ω" by auto
    then
    have "ℵ⇘1⇙⇗M⇖ ≤ ω"
      using Card_rel_Aleph_rel Card_rel_cardinal_rel_eq
      by auto
    then
    have "False"
      using nat_lt_Aleph_rel1 by (blast dest:lt_trans2)
  }
  with ‹range(f)⊆ω› ‹M(f)›
  obtain n where "n∈ω" "¬(|f -`` {n}|⇗M⇖ < ℵ⇘1⇙⇗M⇖)" "M(f -`` {n})"
    using nat_into_M by auto
  moreover from this
  have "ℵ⇘1⇙⇗M⇖ ≤ |f-``{n}|⇗M⇖"
    using not_lt_iff_le Card_rel_is_Ord by simp
  moreover
  note ‹n∈ω ⟹ f-``{n} ⊆ ℵ⇘1⇙⇗M⇖›
  ultimately
  show ?thesis
    using subset_imp_le_cardinal_rel[THEN le_anti_sym, of _ "ℵ⇘1⇙⇗M⇖"]
      Card_rel_Aleph_rel Card_rel_cardinal_rel_eq
    by auto
qed

― ‹There is some asymmetry between assumptions and conclusion
    (term‹eqpoll_rel› versus term‹cardinal_rel›)›

lemma eqpoll_rel_Aleph_rel1_cardinal_rel_vimage:
  assumes "Z ≈⇗M⇖ (ℵ⇘1⇙⇗M⇖)" "f ∈ Z →⇗M⇖ ω" "M(Z)"
  shows "∃n∈ω. |f-``{n}|⇗M⇖ = ℵ⇘1⇙⇗M⇖"
proof -
  have "M(1)" "M(ω)" by simp_all
  then
  have "M(ℵ⇘1⇙⇗M⇖)" by simp
  with assms ‹M(1)›
  obtain g where A:"g∈bij_rel(M,ℵ⇘1⇙⇗M⇖,Z)" "M(g)"
    using eqpoll_rel_sym unfolding eqpoll_rel_def by blast
  with ‹f : Z →⇗M⇖ ω› assms
  have "M(f)" "converse(g) ∈ bij_rel(M,Z, ℵ⇘1⇙⇗M⇖)" "f∈Z→ω" "g∈ ℵ⇘1⇙⇗M⇖→Z"
    using bij_rel_is_fun_rel bij_rel_converse_bij_rel bij_rel_char function_space_rel_char
    by simp_all
  with ‹g∈bij_rel(M,ℵ⇘1⇙⇗M⇖,Z)› ‹M(g)›
  have "f O g : ℵ⇘1⇙⇗M⇖ →⇗M⇖ ω" "M(converse(g))"
    using comp_fun[OF _ ‹f∈ Z→_›,of g] function_space_rel_char
    by simp_all
  then
  obtain n where "n∈ω" "|(f O g)-``{n}|⇗M⇖ = ℵ⇘1⇙⇗M⇖"
    using Aleph_rel1_eq_cardinal_rel_vimage
    by auto
  with ‹M(f)› ‹M(converse(g))›
  have "M(converse(g) `` (f -`` {n}))" "f -`` {n} ⊆ Z"
    using image_comp converse_comp Pi_iff[THEN iffD1,OF ‹f∈Z→ω›] vimage_subset
    unfolding vimage_def
    using transM[OF ‹n∈ω›]
    by auto
  from ‹n∈ω› ‹|(f O g)-``{n}|⇗M⇖ = ℵ⇘1⇙⇗M⇖›
  have "ℵ⇘1⇙⇗M⇖ = |converse(g) `` (f -``{n})|⇗M⇖"
    using image_comp converse_comp unfolding vimage_def
    by auto
  also from ‹converse(g) ∈ bij_rel(M,Z, ℵ⇘1⇙⇗M⇖)› ‹f: Z→⇗M⇖ ω› ‹M(Z)› ‹M(f)› ‹M(ℵ⇘1⇙⇗M⇖)›
    ‹M(converse(g) `` (f -`` {n}))›
  have "… = |f -``{n}|⇗M⇖"
    using range_of_subset_eqpoll_rel[of "converse(g)" Z  _ "f -``{n}",
        OF bij_rel_is_inj_rel[OF ‹converse(g)∈_›] ‹f -`` {n} ⊆ Z›]
      cardinal_rel_cong vimage_closed[OF singleton_closed[OF transM[OF ‹n∈ω›]],of f]
    by auto
  finally
  show ?thesis using ‹n∈_› by auto
qed


subsection‹Applications of transfinite recursive constructions›

definition
  rec_constr :: "[i,i] ⇒ i" where
  "rec_constr(f,α) ≡ transrec(α,λa g. f`(g``a))"

text‹The function term‹rec_constr› allows to perform ∗‹recursive
     constructions›: given a choice function on the powerset of some
     set, a transfinite sequence is created by successively choosing
     some new element.

     The next result explains its use.›

lemma rec_constr_unfold: "rec_constr(f,α) = f`({rec_constr(f,β). β∈α})"
  using def_transrec[OF rec_constr_def, of f α] image_lam by simp

lemma rec_constr_type:
  assumes "f:Pow_rel(M,G)→⇗M⇖ G" "Ord(α)" "M(G)"
  shows "M(α) ⟹ rec_constr(f,α) ∈ G"
  using assms(2)
proof(induct rule:trans_induct)
  case (step β)
  with assms
  have "{rec_constr(f, x) . x ∈ β} = {y . x ∈ β, y=rec_constr(f, x)}" (is "_ = ?Y")
    "M(f)"
    using transM[OF _ ‹M(β)›] function_space_rel_char  Ord_in_Ord
    by auto
  moreover from assms this step ‹M(β)› ‹Ord(β)›
  have "M({y . x ∈ β, y=<x,rec_constr(f, x)>})" (is "M(?Z)")
    using strong_replacement_closed[OF cardinal_lib_assms6(1),of f β β,OF _ _ _ _
        univalent_conjI2[where P="λx _ . x∈β",OF univalent_triv]]
      transM[OF _ ‹M(β)›] transM[OF step(2) ‹M(G)›] Ord_in_Ord
    unfolding rec_constr_def
    by auto
  moreover from assms this step ‹M(β)› ‹Ord(β)›
  have "?Y = {snd(y) . y∈?Z}"
  proof(intro equalityI, auto)
    fix u
    assume "u∈β"
    with assms this step ‹M(β)› ‹Ord(β)›
    have "<u,rec_constr(f,u)> ∈ ?Z"  "rec_constr(f, u) = snd(<u,rec_constr(f,u)>)"
      by auto
    then
    show "∃x∈{y . x ∈ β, y = ⟨x, rec_constr(f, x)⟩}. rec_constr(f, u) = snd(x)"
      using bexI[of _ u] by force
  qed
  moreover from ‹M(?Z)› ‹?Y = _›
  have "M(?Y)"
    using
      RepFun_closed[OF lam_replacement_imp_strong_replacement[OF lam_replacement_snd] ‹M(?Z)›]
      fst_snd_closed[THEN conjunct2] transM[OF _ ‹M(?Z)›]
    by simp
  moreover from assms step
  have "{rec_constr(f, x) . x ∈ β} ∈ Pow(G)" (is "?X∈_")
    using transM[OF _ ‹M(β)›] function_space_rel_char
    by auto
  moreover from assms calculation step
  have "M(?X)"
    by simp
  moreover from calculation ‹M(G)›
  have "?X∈Pow_rel(M,G)"
    using Pow_rel_char by simp
  ultimately
  have "f`?X ∈ G"
    using assms apply_type[OF mem_function_space_rel[of f],of "Pow_rel(M,G)" G ?X]
    by auto
  then
  show ?case
    by (subst rec_constr_unfold,simp)
qed

lemma rec_constr_closed :
  assumes "f:Pow_rel(M,G)→⇗M⇖ G" "Ord(α)" "M(G)" "M(α)"
  shows "M(rec_constr(f,α))"
  using transM[OF rec_constr_type ‹M(G)›] assms by auto

lemma lambda_rec_constr_closed :
  assumes "Ord(γ)" "M(γ)" "M(f)" "f:Pow_rel(M,G)→⇗M⇖ G" "M(G)"
  shows "M(λα∈γ . rec_constr(f,α))"
  using lam_closed2[OF cardinal_lib_assms6(1),unfolded rec_constr_def[symmetric],of f γ]
    rec_constr_type[OF ‹f∈_› Ord_in_Ord[of γ]] transM[OF _ ‹M(G)›] assms
  by simp

text‹The next lemma is an application of recursive constructions.
     It works under the assumption that whenever the already constructed
     subsequence is small enough, another element can be added.›

lemma bounded_cardinal_rel_selection:
  includes Ord_dests
  assumes
    "⋀Z. |Z|⇗M⇖ < γ ⟹ Z ⊆ G ⟹ M(Z) ⟹ ∃a∈G. ∀s∈Z. <s,a>∈Q" "b∈G" "Card_rel(M,γ)"
    "M(G)" "M(Q)" "M(γ)"
  shows
    "∃S[M]. S : γ →⇗M⇖ G ∧ (∀α ∈ γ. ∀β ∈ γ.  α<β ⟶ <S`α,S`β>∈Q)"
proof -
  from assms
  have "M(x) ⟹ M({a ∈ G . ∀s∈x. ⟨s, a⟩ ∈ Q})" for x
    using cdlt_assms' by simp
  let ?cdltγ="{Z∈Pow_rel(M,G) . |Z|⇗M⇖<γ}" ― ‹“cardinal\_rel less than term‹γ›”›
    and ?inQ="λY.{a∈G. ∀s∈Y. <s,a>∈Q}"
  from ‹M(G)› ‹Card_rel(M,γ)› ‹M(γ)›
  have "M(?cdltγ)" "Ord(γ)"
    using cardinal_lib_assms5[OF ‹M(γ)›] Card_rel_is_Ord
    by simp_all
  from assms
  have H:"∃a. a ∈ ?inQ(Y)" if "Y∈?cdltγ" for Y
  proof -
    {
      fix Y
      assume "Y∈?cdltγ"
      then
      have A:"Y∈Pow_rel(M,G)" "|Y|⇗M⇖<γ"  by simp_all
      then
      have "Y⊆G" "M(Y)" using Pow_rel_char[OF ‹M(G)›] by simp_all
      with A
      obtain a where "a∈G" "∀s∈Y. <s,a>∈Q"
        using assms(1) by force
      with ‹M(G)›
      have "∃a. a ∈ ?inQ(Y)" by auto
    }
    then show ?thesis using that by simp
  qed
  then
  have "∃f[M]. f ∈ Pi_rel(M,?cdltγ,?inQ) ∧ f ∈ Pi(?cdltγ,?inQ)"
  proof -
    from ‹⋀x. M(x) ⟹ M({a ∈ G . ∀s∈x. ⟨s, a⟩ ∈ Q})› ‹M(G)›
    have "x ∈ {Z ∈ Pow⇗M⇖(G) . |Z|⇗M⇖ < γ} ⟹ M({a ∈ G . ∀s∈x. ⟨s, a⟩ ∈ Q})" for x
      by (auto dest:transM)
    with‹M(G)› ‹⋀x. M(x) ⟹ M({a ∈ G . ∀s∈x. ⟨s, a⟩ ∈ Q})› ‹M(Q)› ‹M(?cdltγ)›
    interpret M_Pi_assumptions_choice M ?cdltγ ?inQ
      using cdlt_assms[where Q=Q] lam_replacement_Collect_ball_Pair[THEN
          lam_replacement_imp_strong_replacement] surj_imp_inj_replacement3
        lam_replacement_hcomp2[OF lam_replacement_constant
          lam_replacement_Collect_ball_Pair _ _ lam_replacement_minimum,
          unfolded lam_replacement_def]
        lam_replacement_hcomp lam_replacement_Sigfun[OF
          lam_replacement_Collect_ball_Pair, of G Q, THEN
          lam_replacement_imp_strong_replacement] cdlt_assms'
      by unfold_locales (blast dest: transM, auto dest:transM)
    show ?thesis using AC_Pi_rel Pi_rel_char H by auto
  qed
  then
  obtain f where f_type:"f ∈ Pi_rel(M,?cdltγ,?inQ)" "f ∈ Pi(?cdltγ,?inQ)" and "M(f)"
    by auto
  moreover
  define Cb where "Cb ≡ λ_∈Pow_rel(M,G)-?cdltγ. b"
  moreover from ‹b∈G› ‹M(?cdltγ)› ‹M(G)›
  have "Cb ∈ Pow_rel(M,G)-?cdltγ → G" "M(Cb)"
    using lam_closed[of "λ_.b" "Pow_rel(M,G)-?cdltγ"]
      tag_replacement transM[OF ‹b∈G›]
    unfolding Cb_def by auto
  moreover
  note ‹Card_rel(M,γ)›
  ultimately
  have "f ∪ Cb : (∏x∈Pow_rel(M,G). ?inQ(x) ∪ G)" using
      fun_Pi_disjoint_Un[ of f ?cdltγ  ?inQ Cb "Pow_rel(M,G)-?cdltγ" "λ_.G"]
      Diff_partition[of "{Z∈Pow_rel(M,G). |Z|⇗M⇖<γ}" "Pow_rel(M,G)", OF Collect_subset]
    by auto
  moreover
  have "?inQ(x) ∪ G = G" for x by auto
  moreover from calculation
  have "f ∪ Cb : Pow_rel(M,G) → G"
    using function_space_rel_char by simp
  ultimately
  have "f ∪ Cb : Pow_rel(M,G) →⇗M⇖ G"
    using function_space_rel_char ‹M(f)› ‹M(Cb)› Pow_rel_closed ‹M(G)›
    by auto
  define S where "S≡λα∈γ. rec_constr(f ∪ Cb, α)"
  from ‹f ∪ Cb: Pow_rel(M,G) →⇗M⇖ G› ‹Card_rel(M,γ)› ‹M(γ)› ‹M(G)›
  have "S : γ → G" "M(f ∪ Cb)"
    unfolding S_def
    using Ord_in_Ord[OF Card_rel_is_Ord] rec_constr_type lam_type transM[OF _ ‹M(γ)›]
      function_space_rel_char
    by auto
  moreover from ‹f∪Cb ∈ _→⇗M⇖ G› ‹Card_rel(M,γ)› ‹M(γ)› ‹M(G)› ‹M(f ∪ Cb)› ‹Ord(γ)›
  have "M(S)"
    unfolding S_def
    using lambda_rec_constr_closed
    by simp
  moreover
  have "∀α∈γ. ∀β∈γ. α < β ⟶ <S ` α, S ` β>∈Q"
  proof (intro ballI impI)
    fix α β
    assume "β∈γ"
    with ‹Card_rel(M,γ)› ‹M(S)› ‹M(γ)›
    have "β⊆γ" "M(S``β)" "M(β)" "{S`x . x ∈ β} = {restrict(S,β)`x . x ∈ β}"
      using transM[OF ‹β∈γ› ‹M(γ)›] image_closed Card_rel_is_Ord OrdmemD
      by auto
    with ‹β∈_› ‹Card_rel(M,γ)› ‹M(γ)›
    have "{rec_constr(f ∪ Cb, x) . x∈β} = {S`x . x ∈ β}"
      using Ord_trans[OF _ _ Card_rel_is_Ord, of _ β γ]
      unfolding S_def
      by auto
    moreover from ‹β∈γ› ‹S : γ → G› ‹Card_rel(M,γ)› ‹M(γ)› ‹M(S``β)›
    have "{S`x . x ∈ β} ⊆ G" "M({S`x . x ∈ β})"
      using Ord_trans[OF _ _ Card_rel_is_Ord, of _ β γ]
        apply_type[of S γ "λ_. G"]
      by(auto,simp add:image_fun_subset[OF ‹S∈_› ‹β⊆_›])
    moreover from ‹Card_rel(M,γ)› ‹β∈γ› ‹S∈_› ‹β⊆γ› ‹M(S)› ‹M(β)› ‹M(G)› ‹M(γ)›
    have "|{S`x . x ∈ β}|⇗M⇖ < γ"
      using
        ‹{S`x . x∈β} = {restrict(S,β)`x . x∈β}›[symmetric]
        cardinal_rel_RepFun_apply_le[of "restrict(S,β)" β G,
          OF restrict_type2[of S γ "λ_.G" β] restrict_closed]
        Ord_in_Ord Ord_cardinal_rel
        lt_trans1[of "|{S`x . x ∈ β}|⇗M⇖" "|β|⇗M⇖" γ]
        Card_rel_lt_iff[THEN iffD2, of β γ, OF _ _ _ _ ltI]
        Card_rel_is_Ord
      by auto
    moreover
    have "∀x∈β. <S`x, f ` {S`x . x ∈ β}> ∈ Q"
    proof -
      from calculation and f_type
      have "f ` {S`x . x ∈ β} ∈ {a∈G. ∀x∈β. <S`x,a>∈Q}"
        using apply_type[of f ?cdltγ ?inQ "{S`x . x ∈ β}"]
          Pow_rel_char[OF ‹M(G)›]
        by simp
      then
      show ?thesis by simp
    qed
    moreover
    assume "α∈γ" "α < β"
    moreover from this
    have "α∈β" using ltD by simp
    moreover
    note ‹β∈γ› ‹Cb ∈ Pow_rel(M,G)-?cdltγ → G›
    ultimately
    show "<S ` α, S ` β>∈Q"
      using fun_disjoint_apply1[of "{S`x . x ∈ β}" Cb f]
        domain_of_fun[of Cb] ltD[of α β]
      by (subst (2) S_def, auto) (subst rec_constr_unfold, auto)
  qed
  moreover
  note ‹M(G)› ‹M(γ)›
  ultimately
  show ?thesis using function_space_rel_char by auto
qed

text‹The following basic result can, in turn, be proved by a
     bounded-cardinal\_rel selection.›
lemma Infinite_iff_lepoll_rel_nat: "M(Z) ⟹ Infinite(Z) ⟷ ω ≲⇗M⇖ Z"
proof
  define Distinct where "Distinct = {<x,y> ∈ Z×Z . x≠y}"
  have "Distinct = {xy ∈ Z×Z . ∃a b. xy = ⟨a, b⟩ ∧ a ≠ b}" (is "_=?A")
    unfolding Distinct_def by auto
  moreover
  assume "Infinite(Z)" "M(Z)"
  moreover from calculation
  have "M(Distinct)"
    using cardinal_lib_assms6 separation_dist by simp
  from ‹Infinite(Z)› ‹M(Z)›
  obtain b where "b∈Z"
    using Infinite_not_empty by auto
  {
    fix Y
    assume "|Y|⇗M⇖ < ω" "M(Y)"
    then
    have "Finite(Y)"
      using Finite_cardinal_rel_iff' ltD nat_into_Finite by auto
    with ‹Infinite(Z)›
    have "Z ≠ Y" by auto
  }
  moreover
  have "(⋀W. M(W) ⟹ |W|⇗M⇖ < ω ⟹ W ⊆ Z ⟹ ∃a∈Z. ∀s∈W. <s,a>∈Distinct)"
  proof -
    fix W
    assume "M(W)" "|W|⇗M⇖ < ω" "W ⊆ Z"
    moreover from this
    have "Finite_rel(M,W)"
      using
        cardinal_rel_closed[OF ‹M(W)›] Card_rel_nat
        lt_Card_rel_imp_lesspoll_rel[of ω,simplified,OF _ ‹|W|⇗M⇖ < ω›]
        lesspoll_rel_nat_is_Finite_rel[of W]
        eqpoll_rel_imp_lepoll_rel eqpoll_rel_sym[OF cardinal_rel_eqpoll_rel,of W]
        lesspoll_rel_trans1[of W "|W|⇗M⇖" ω] by auto
    moreover from calculation
    have "¬Z⊆W"
      using equalityI ‹Infinite(Z)› by auto
    moreover from calculation
    show "∃a∈Z. ∀s∈W. <s,a>∈Distinct"
      unfolding Distinct_def by auto
  qed
  moreover from ‹b∈Z› ‹M(Z)› ‹M(Distinct)› this
  obtain S where "S : ω →⇗M⇖ Z" "M(S)" "∀α∈ω. ∀β∈ω. α < β ⟶ <S`α,S`β> ∈ Distinct"
    using bounded_cardinal_rel_selection[OF _ ‹b∈Z› Card_rel_nat,of Distinct]
    by blast
  moreover from this
  have "α ∈ ω ⟹ β ∈ ω ⟹ α≠β ⟹ S`α ≠ S`β" for α β
    unfolding Distinct_def
    by (rule_tac lt_neq_symmetry[of "ω" "λα β. S`α ≠ S`β"])
      auto
  moreover from this ‹S∈_› ‹M(Z)›
  have "S∈inj(ω,Z)" using function_space_rel_char unfolding inj_def by auto
  ultimately
  show "ω ≲⇗M⇖ Z"
    unfolding lepoll_rel_def using inj_rel_char ‹M(Z)› by auto
next
  assume "ω ≲⇗M⇖ Z" "M(Z)"
  then
  show "Infinite(Z)" using lepoll_rel_nat_imp_Infinite by simp
qed

lemma Infinite_InfCard_rel_cardinal_rel: "Infinite(Z) ⟹ M(Z) ⟹ InfCard_rel(M,|Z|⇗M⇖)"
  using lepoll_rel_eq_trans eqpoll_rel_sym lepoll_rel_nat_imp_Infinite
    Infinite_iff_lepoll_rel_nat Inf_Card_rel_is_InfCard_rel cardinal_rel_eqpoll_rel
  by simp

lemma (in M_trans) mem_F_bound2:
  fixes F A
  defines "F ≡ λ_ x. if M(x) then A-``{x} else 0"
  shows "x∈F(A,c) ⟹ c ∈ (range(f) ∪ range(A))"
  using apply_0 unfolding F_def
  by (cases "M(c)", auto simp:F_def drSR_Y_def dC_F_def)

lemma Finite_to_one_rel_surj_rel_imp_cardinal_rel_eq:
  assumes "F ∈ Finite_to_one_rel(M,Z,Y) ∩ surj_rel(M,Z,Y)" "Infinite(Z)" "M(Z)" "M(Y)"
  shows "|Y|⇗M⇖ = |Z|⇗M⇖"
proof -
  have sep_true: "separation(M, M)" unfolding separation_def by auto
  note ‹M(Z)› ‹M(Y)›
  moreover from this assms
  have "M(F)" "F ∈ Z → Y"
    unfolding Finite_to_one_rel_def
    using function_space_rel_char by simp_all
  moreover from this
  have "x ∈ (if M(i) then F -`` {i} else 0) ⟹ M(i)" for x i
    by (cases "M(i)") auto
  moreover from calculation
  interpret M_replacement_lepoll M "λ_ x. if M(x) then F-``{x} else 0"
    using lam_replacement_inj_rel mem_F_bound2 cardinal_lib_assms3
      lam_replacement_vimage_sing_fun
      lam_replacement_if[OF _
        lam_replacement_constant[OF nonempty],where b=M] sep_true
    by (unfold_locales, simp_all)
      (rule lam_Least_assumption_general[where U="λ_. range(F)"], auto)
  have "w ∈ (if M(y) then F-``{y} else 0) ⟹ M(y)" for w y
    by (cases "M(y)") auto
  moreover from ‹F∈_∩_›
  have 0:"Finite(F-``{y})" if "y∈Y" for y
    unfolding Finite_to_one_rel_def
    using vimage_fun_sing ‹F∈Z→Y› transM[OF that ‹M(Y)›] transM[OF _ ‹M(Z)›] that by simp
  ultimately
  interpret M_cardinal_UN_lepoll _ "λy. if M(y) then F-``{y} else 0" Y
    using cardinal_lib_assms3 lepoll_assumptions
    by unfold_locales  (auto dest:transM simp del:mem_inj_abs)
  from ‹F∈Z→Y›
  have "Z = (⋃y∈Y. {x∈Z . F`x = y})"
    using apply_type by auto
  then
  show ?thesis
  proof (cases "Finite(Y)")
    case True
    with ‹Z = (⋃y∈Y. {x∈Z . F`x = y})› and assms and ‹F∈Z→Y›
    show ?thesis
      using Finite_RepFun[THEN [2] Finite_Union, of Y "λy. F-``{y}"] 0 vimage_fun_sing[OF ‹F∈Z→Y›]
      by simp
  next
    case False
    moreover from this ‹M(Y)›
    have "Y ≲⇗M⇖ |Y|⇗M⇖"
      using cardinal_rel_eqpoll_rel eqpoll_rel_sym eqpoll_rel_imp_lepoll_rel by auto
    moreover
    note assms
    moreover from ‹F∈_∩_›
    have "Finite({x∈Z . F`x = y})" "M(F-``{y})" if "y∈Y" for y
      unfolding Finite_to_one_rel_def
      using transM[OF that  ‹M(Y)›] transM[OF _ ‹M(Z)›] vimage_fun_sing[OF ‹F∈Z→Y›] that
      by simp_all
    moreover from calculation
    have "|{x∈Z . F`x = y}|⇗M⇖ ∈ ω" if "y∈Y" for y
      using Finite_cardinal_rel_in_nat that transM[OF that ‹M(Y)›] vimage_fun_sing[OF ‹F∈Z→Y›] that
      by simp
    moreover from calculation
    have "|{x∈Z . F`x = y}|⇗M⇖ ≤ |Y|⇗M⇖" if "y∈Y" for y
      using Infinite_imp_nats_lepoll_rel[THEN lepoll_rel_imp_cardinal_rel_le,
          of _ "|{x∈Z . F`x = y}|⇗M⇖"]
        that cardinal_rel_idem transM[OF that ‹M(Y)›] vimage_fun_sing[OF ‹F∈Z→Y›]
      by auto
    ultimately
    have "|⋃y∈Y. {x∈Z . F`x = y}|⇗M⇖ ≤ |Y|⇗M⇖"
      using leqpoll_rel_imp_cardinal_rel_UN_le
        Infinite_InfCard_rel_cardinal_rel[of Y] vimage_fun_sing[OF ‹F∈Z→Y›]
      by(auto simp add:transM[OF _ ‹M(Y)›])
    moreover from ‹F ∈ Finite_to_one_rel(M,Z,Y) ∩ surj_rel(M,Z,Y)› ‹M(Z)› ‹M(F)› ‹M(Y)›
    have "|Y|⇗M⇖ ≤ |Z|⇗M⇖"
      using surj_rel_implies_cardinal_rel_le by auto
    moreover
    note ‹Z = (⋃y∈Y. {x∈Z . F`x = y})›
    ultimately
    show ?thesis
      using le_anti_sym by auto
  qed
qed

lemma cardinal_rel_map_Un:
  assumes "Infinite(X)" "Finite(b)" "M(X)" "M(b)"
  shows "|{a ∪ b . a ∈ X}|⇗M⇖ = |X|⇗M⇖"
proof -
  have "(λa∈X. a ∪ b) ∈ Finite_to_one_rel(M,X,{a ∪ b . a ∈ X})"
    "(λa∈X. a ∪ b) ∈  surj_rel(M,X,{a ∪ b . a ∈ X})"
    "M({a ∪ b . a ∈ X})"
    unfolding def_surj_rel
  proof
    fix d
    have "Finite({a ∈ X . a ∪ b = d})" (is "Finite(?Y(b,d))")
      using ‹Finite(b)›
    proof (induct arbitrary:d)
      case 0
      have "{a ∈ X . a ∪ 0 = d} = (if d∈X then {d} else 0)"
        by auto
      then
      show ?case by simp
    next
      case (cons c b)
      from ‹c ∉ b›
      have "?Y(cons(c,b),d) ⊆ (if c∈d then ?Y(b,d) ∪ ?Y(b,d-{c}) else 0)"
        by auto
      with cons
      show ?case
        using subset_Finite
        by simp
    qed
    moreover
    assume "d ∈ {x ∪ b . x ∈ X}"
    ultimately
    show "Finite({a ∈ X . M(a) ∧ (λx∈X. x ∪ b) ` a = d})"
      using subset_Finite[of "{a ∈ X . M(a) ∧ (λx∈X. x ∪ b) ` a = d}"
          "{a ∈ X . (λx∈X. x ∪ b) ` a = d}"] by auto
  next
    note ‹M(X)› ‹M(b)›
    moreover
    show "M(λa∈X. a ∪ b)"
      using lam_closed[of "λ x . x∪b",OF _ ‹M(X)›] Un_closed[OF transM[OF _ ‹M(X)›] ‹M(b)›]
        tag_union_replacement[OF ‹M(b)›]
      by simp
    moreover from this
    have "{a ∪ b . a ∈ X} = (λx∈X. x ∪ b) `` X"
      using image_lam by simp
    with calculation
    show "M({a ∪ b . a ∈ X})" by auto
    moreover from calculation
    show "(λa∈X. a ∪ b) ∈ X →⇗M⇖ {a ∪ b . a ∈ X}"
      using function_space_rel_char by (auto intro:lam_funtype)
    ultimately
    show "(λa∈X. a ∪ b) ∈ surj⇗M⇖(X,{a ∪ b . a ∈ X})" "M({a ∪ b . a ∈ X})"
      using surj_rel_char function_space_rel_char
      unfolding surj_def by auto
  next
  qed (simp add:‹M(X)›)
  moreover from assms this
  show ?thesis
    using Finite_to_one_rel_surj_rel_imp_cardinal_rel_eq by simp
qed

subsection‹Results on relative cardinal exponentiation›

lemma cexp_rel_eqpoll_rel_cong:
  assumes
    "A ≈⇗M⇖ A'" "B ≈⇗M⇖ B'" "M(A)" "M(A')" "M(B)" "M(B')"
  shows
    "A⇗↑B,M⇖ = A'⇗↑B',M⇖"
  unfolding cexp_rel_def using cardinal_rel_eqpoll_rel_iff
    function_space_rel_eqpoll_rel_cong assms
  by simp

lemma cexp_rel_cexp_rel_cmult:
  assumes "M(κ)" "M(ν1)" "M(ν2)"
  shows "(κ⇗↑ν1,M⇖)⇗↑ν2,M⇖ = κ⇗↑ν2 ⊗⇗M⇖ ν1,M⇖"
proof -
  have "(κ⇗↑ν1,M⇖)⇗↑ν2,M⇖ = (ν1 →⇗M⇖ κ)⇗↑ν2,M⇖"
    using cardinal_rel_eqpoll_rel
    by (intro cexp_rel_eqpoll_rel_cong) (simp_all add:assms cexp_rel_def)
  also from assms
  have " … = κ⇗↑ν2 × ν1,M⇖"
    unfolding cexp_rel_def using curry_eqpoll_rel[THEN cardinal_rel_cong] by blast
  also
  have " … = κ⇗↑ν2 ⊗⇗M⇖ ν1,M⇖"
    using cardinal_rel_eqpoll_rel[THEN eqpoll_rel_sym]
    unfolding cmult_rel_def by (intro cexp_rel_eqpoll_rel_cong) (auto simp add:assms)
  finally
  show ?thesis .
qed

lemma cardinal_rel_Pow_rel: "M(X) ⟹ |Pow_rel(M,X)|⇗M⇖ = 2⇗↑X,M⇖" ― ‹Perhaps it's better with |X|›
  using cardinal_rel_eqpoll_rel_iff[THEN iffD2,
      OF _ _ Pow_rel_eqpoll_rel_function_space_rel]
  unfolding cexp_rel_def by simp

lemma cantor_cexp_rel:
  assumes "Card_rel(M,ν)" "M(ν)"
  shows "ν < 2⇗↑ν,M⇖"
  using assms Card_rel_is_Ord Card_rel_cexp_rel
proof (intro not_le_iff_lt[THEN iffD1] notI)
  assume "2⇗↑ν,M⇖ ≤ ν"
  with assms
  have "|Pow_rel(M,ν)|⇗M⇖ ≤ ν"
    using cardinal_rel_Pow_rel[of ν] by simp
  with assms
  have "Pow_rel(M,ν) ≲⇗M⇖ ν"
    using cardinal_rel_eqpoll_rel_iff Card_rel_le_imp_lepoll_rel Card_rel_cardinal_rel_eq
    by auto
  then
  obtain g where "g ∈ inj_rel(M,Pow_rel(M,ν), ν)"
    by blast
  moreover
  note ‹M(ν)›
  moreover from calculation
  have "M(g)" by (auto dest:transM)
  ultimately
  show "False"
    using cantor_inj_rel by simp
qed simp

lemma countable_iff_lesspoll_rel_Aleph_rel_one:
  notes iff_trans[trans]
  assumes "M(C)"
  shows "countable⇗M⇖(C) ⟷ C ≺⇗M⇖ ℵ⇘1⇙⇗M⇖"
  using assms lesspoll_rel_csucc_rel[of ω C] Aleph_rel_succ Aleph_rel_zero
  unfolding countable_rel_def by simp


lemma countable_iff_le_rel_Aleph_rel_one:
  notes iff_trans[trans]
  assumes "M(C)"
  shows "countable⇗M⇖(C) ⟷ |C|⇗M⇖ ≺⇗M⇖ ℵ⇘1⇙⇗M⇖"
proof -
  from assms
  have "countable⇗M⇖(C) ⟷ C ≺⇗M⇖ ℵ⇘1⇙⇗M⇖"
    using countable_iff_lesspoll_rel_Aleph_rel_one
    by simp
  also from assms
  have "… ⟷ |C|⇗M⇖ ≺⇗M⇖ ℵ⇘1⇙⇗M⇖"
    using cardinal_rel_eqpoll_rel[THEN eqpoll_rel_sym, THEN eq_lesspoll_rel_trans]
    by (auto intro:cardinal_rel_eqpoll_rel[THEN eq_lesspoll_rel_trans])
  finally
  show ?thesis .
qed

end ― ‹locale‹M_cardinal_library››

(* TODO: This can be generalized. *)
lemma (in M_cardinal_library) countable_fun_imp_countable_image:
  assumes "f:C →⇗M⇖ B" "countable⇗M⇖(C)" "⋀c. c∈C ⟹ countable⇗M⇖(f`c)"
    "M(C)" "M(B)"
  shows "countable⇗M⇖(⋃(f``C))"
  using assms function_space_rel_char image_fun[of f]
    cardinal_rel_RepFun_apply_le[of f C B]
    countable_rel_iff_cardinal_rel_le_nat[THEN iffD1, THEN [2] le_trans, of _ ]
    countable_rel_iff_cardinal_rel_le_nat
  by (rule_tac countable_rel_union_countable_rel)
    (auto dest:transM del:imageE)

end
ad>

Theory Delta_System_Relative

section‹The Delta System Lemma, Relativized\label{sec:dsl-rel}›

theory Delta_System_Relative
  imports
    Cardinal_Library_Relative
begin

(* FIXME: The following code (definition and 3 lemmas) is extracted
   from Delta_System where it is unnecesarily under the context of AC *)
definition
  delta_system :: "i ⇒ o" where
  "delta_system(D) ≡ ∃r. ∀A∈D. ∀B∈D. A ≠ B ⟶ A ∩ B = r"

lemma delta_systemI[intro]:
  assumes "∀A∈D. ∀B∈D. A ≠ B ⟶ A ∩ B = r"
  shows "delta_system(D)"
  using assms unfolding delta_system_def by simp

lemma delta_systemD[dest]:
  "delta_system(D) ⟹ ∃r. ∀A∈D. ∀B∈D. A ≠ B ⟶ A ∩ B = r"
  unfolding delta_system_def by simp

lemma delta_system_root_eq_Inter:
  assumes "delta_system(D)"
  shows "∀A∈D. ∀B∈D. A ≠ B ⟶ A ∩ B = ⋂D"
proof (clarify, intro equalityI, auto)
  fix A' B' x C
  assume hyp:"A'∈D" "B'∈ D" "A'≠B'" "x∈A'" "x∈B'" "C∈D"
  with assms
  obtain r where delta:"∀A∈D. ∀B∈D. A ≠ B ⟶ A ∩ B = r"
    by auto
  show "x ∈ C"
  proof (cases "C=A'")
    case True
    with hyp and assms
    show ?thesis by simp
  next
    case False
    moreover
    note hyp
    moreover from calculation and delta
    have "r = C ∩ A'" "A' ∩ B' = r" "x∈r" by auto
    ultimately
    show ?thesis by simp
  qed
qed

relativize functional "delta_system" "delta_system_rel" external

locale M_delta = M_cardinal_library +
  assumes
    countable_lepoll_assms:
    "M(G) ⟹ M(A) ⟹ M(b) ⟹ M(f) ⟹ separation(M, λy. ∃x∈A.
                          y = ⟨x, μ i. x ∈ if_range_F_else_F(λx. {xa ∈ G . x ∈ xa}, b, f, i)⟩)"
begin

lemmas cardinal_replacement = lam_replacement_cardinal_rel[unfolded lam_replacement_def]

lemma disjoint_separation: "M(c) ⟹ separation(M, λ x. ∃a. ∃b. x=⟨a,b⟩ ∧ a ∩ b = c)"
  using separation_pair separation_eq lam_replacement_constant lam_replacement_Int
  by simp

lemma insnd_ball: "M(G) ⟹ separation(M, λp. ∀x∈G. x ∈ snd(p) ⟷ fst(p) ∈ x)"
  using separation_ball separation_iff' lam_replacement_fst lam_replacement_snd
    separation_in lam_replacement_hcomp
  by simp

lemma (in M_trans) mem_F_bound6:
  fixes F G
  defines "F ≡ λ_ x. Collect(G, (∈)(x))"
  shows "x∈F(G,c) ⟹ c ∈ (range(f) ∪ ⋃G)"
  using apply_0 unfolding F_def
  by (cases "M(c)", auto simp:F_def)

lemma delta_system_Aleph_rel1:
  assumes "∀A∈F. Finite(A)" "F ≈⇗M⇖ ℵ⇘1⇙⇗M⇖" "M(F)"
  shows "∃D[M]. D ⊆ F ∧ delta_system(D) ∧ D ≈⇗M⇖ ℵ⇘1⇙⇗M⇖"
proof -
  have "M(G) ⟹ M(p) ⟹ M({A∈G . p ∈ A})" for G p
  proof -
    assume "M(G)" "M(p)"
    have "{A∈G . p ∈ A} = G ∩ (Memrel({p} ∪ G) `` {p})"
      unfolding Memrel_def by auto
    with ‹M(G)› ‹M(p)›
    show ?thesis by simp
  qed
  from ‹M(F)›
  have "M(λA∈F. |A|⇗M⇖)"
    using cardinal_replacement
    by (rule_tac lam_closed) (auto dest:transM)
  text‹Since all members are finite,›
  with ‹∀A∈F. Finite(A)› ‹M(F)›
  have "(λA∈F. |A|⇗M⇖) : F →⇗M⇖ ω" (is "?cards : _")
    by (simp add:mem_function_space_rel_abs, rule_tac lam_type)
      (force dest:transM)
  moreover from this
  have a:"?cards -`` {n} = { A∈F . |A|⇗M⇖ = n }" for n
    using vimage_lam by auto
  moreover
  note ‹F ≈⇗M⇖ ℵ⇘1⇙⇗M⇖› ‹M(F)›
  moreover from calculation
  text‹there are uncountably many have the same cardinal:›
  obtain n where "n∈ω" "|?cards -`` {n}|⇗M⇖ = ℵ⇘1⇙⇗M⇖"
    using eqpoll_rel_Aleph_rel1_cardinal_rel_vimage[of F ?cards] by auto
  moreover
  define G where "G ≡ ?cards -`` {n}"
  moreover from calculation and ‹M(?cards)›
  have "M(G)" by blast
  moreover from calculation
  have "G ⊆ F" by auto
  ultimately
  text‹Therefore, without loss of generality, we can assume that all
  elements of the family have cardinality term‹n∈ω›.›
  have "A∈G ⟹ |A|⇗M⇖ = n" and "G ≈⇗M⇖ ℵ⇘1⇙⇗M⇖" and "M(G)" for A
    using cardinal_rel_Card_rel_eqpoll_rel_iff by auto
  with ‹n∈ω›
  text‹So we prove the result by induction on this term‹n› and
  generalizing term‹G›, since the argument requires changing the
  family in order to apply the inductive hypothesis.›
  have "∃D[M]. D ⊆ G ∧ delta_system(D) ∧ D ≈⇗M⇖ ℵ⇘1⇙⇗M⇖"
  proof (induct arbitrary:G)
    case 0 ― ‹This case is impossible›
    then
    have "G ⊆ {0}"
      using cardinal_rel_0_iff_0 by (blast dest:transM)
    with ‹G ≈⇗M⇖ ℵ⇘1⇙⇗M⇖› ‹M(G)›
    show ?case
      using nat_lt_Aleph_rel1 subset_imp_le_cardinal_rel[of G "{0}"]
        lt_trans2 cardinal_rel_Card_rel_eqpoll_rel_iff by auto
  next
    case (succ n)
    have "∀a∈G. Finite(a)"
    proof
      fix a
      assume "a ∈ G"
      moreover
      note ‹M(G)› ‹n∈ω›
      moreover from calculation
      have "M(a)" by (auto dest: transM)
      moreover from succ and ‹a∈G›
      have "|a|⇗M⇖ = succ(n)" by simp
      ultimately
      show "Finite(a)"
        using Finite_cardinal_rel_iff' nat_into_Finite[of "succ(n)"]
        by fastforce
    qed
    show "∃D[M]. D ⊆ G ∧ delta_system(D) ∧ D ≈⇗M⇖ ℵ⇘1⇙⇗M⇖"
    proof (cases "∃p[M]. {A∈G . p ∈ A} ≈⇗M⇖ ℵ⇘1⇙⇗M⇖")
      case True ― ‹the positive case, uncountably many sets with a
                    common element›
      then
      obtain p where "{A∈G . p ∈ A} ≈⇗M⇖ ℵ⇘1⇙⇗M⇖" "M(p)" by blast
      moreover
      note 1=‹M(G)› ‹M(G) ⟹ M(p) ⟹ M({A∈G . p ∈ A})› singleton_closed[OF ‹M(p)›]
      moreover from this
      have "M({x - {p} . x ∈ {x ∈ G . p ∈ x}})"
        using RepFun_closed[OF lam_replacement_Diff'[THEN
              lam_replacement_imp_strong_replacement]]
          Diff_closed[OF transM[OF _ 1(2)]] by auto
      moreover from 1
      have "M(converse(λx∈{x ∈ G . p ∈ x}. x - {p}))" (is "M(converse(?h))")
        using converse_closed[of ?h] lam_closed[OF diff_Pair_replacement]
          Diff_closed[OF transM[OF _ 1(2)]]
        by auto
      moreover from calculation
      have "{A-{p} . A∈{X∈G. p∈X}} ≈⇗M⇖ ℵ⇘1⇙⇗M⇖" (is "?F ≈⇗M⇖ _")
        using Diff_bij_rel[of "{A∈G . p ∈ A}" "{p}", THEN
            comp_bij_rel[OF bij_rel_converse_bij_rel, where C="ℵ⇘1⇙⇗M⇖",
              THEN bij_rel_imp_eqpoll_rel, of _ _ ?F]]
        unfolding eqpoll_rel_def
        by (auto simp del:mem_bij_abs)
      text‹Now using the hypothesis of the successor case,›
      moreover from ‹⋀A. A∈G ⟹ |A|⇗M⇖=succ(n)› ‹∀a∈G. Finite(a)›
        and this ‹M(G)›
      have "p∈A ⟹ A∈G ⟹ |A - {p}|⇗M⇖ = n" for A
        using Finite_imp_succ_cardinal_rel_Diff[of _ p] by (force dest: transM)
      moreover
      have "∀a∈?F. Finite(a)"
      proof (clarsimp)
        fix A
        assume "p∈A" "A∈G"
        with ‹⋀A. p ∈ A ⟹ A ∈ G ⟹ |A - {p}|⇗M⇖ = n› and ‹n∈ω› ‹M(G)›
        have "Finite(|A - {p}|⇗M⇖)"
          using nat_into_Finite by simp
        moreover from ‹p∈A› ‹A∈G› ‹M(G)›
        have "M(A - {p})" by (auto dest: transM)
        ultimately
        show "Finite(A - {p})"
          using Finite_cardinal_rel_iff' by simp
      qed
      moreover
      text‹we may apply the inductive hypothesis to the new family term‹?F›:›
      note ‹(⋀A. A ∈ ?F ⟹ |A|⇗M⇖ = n) ⟹ ?F ≈⇗M⇖ ℵ⇘1⇙⇗M⇖ ⟹ M(?F) ⟹
             ∃D[M]. D ⊆ ?F ∧ delta_system(D) ∧ D ≈⇗M⇖ ℵ⇘1⇙⇗M⇖›
      moreover
      note 1=‹M(G)› ‹M(G) ⟹ M(p) ⟹ M({A∈G . p ∈ A})› singleton_closed[OF ‹M(p)›]
      moreover from this
      have "M({x - {p} . x ∈ {x ∈ G . p ∈ x}})"
        using RepFun_closed[OF lam_replacement_Diff'[THEN
              lam_replacement_imp_strong_replacement]]
          Diff_closed[OF transM[OF _ 1(2)]] by auto
      ultimately
      obtain D where "D⊆{A-{p} . A∈{X∈G. p∈X}}" "delta_system(D)" "D ≈⇗M⇖ ℵ⇘1⇙⇗M⇖" "M(D)"
        by auto
      moreover from this
      obtain r where "∀A∈D. ∀B∈D. A ≠ B ⟶ A ∩ B = r"
        by fastforce
      then
      have "∀A∈D.∀B∈D. A∪{p} ≠ B∪{p}⟶(A ∪ {p}) ∩ (B ∪ {p}) = r∪{p}"
        by blast
      ultimately
      have "delta_system({B ∪ {p} . B∈D})" (is "delta_system(?D)")
        by fastforce
      moreover from ‹M(D)› ‹M(p)›
      have "M(?D)"
        using RepFun_closed un_Pair_replacement transM[of _ D] by auto
      moreover from ‹D ≈⇗M⇖ ℵ⇘1⇙⇗M⇖› ‹M(D)›
      have "Infinite(D)" "|D|⇗M⇖ = ℵ⇘1⇙⇗M⇖"
        using uncountable_rel_iff_subset_eqpoll_rel_Aleph_rel1[THEN iffD2,
            THEN uncountable_rel_imp_Infinite, of D]
          cardinal_rel_eqpoll_rel_iff[of D "ℵ⇘1⇙⇗M⇖"] ‹M(D)› ‹D ≈⇗M⇖ ℵ⇘1⇙⇗M⇖›
        by auto
      moreover from this ‹M(?D)› ‹M(D)› ‹M(p)›
      have "?D ≈⇗M⇖ ℵ⇘1⇙⇗M⇖"
        using cardinal_rel_map_Un[of D "{p}"] naturals_lt_nat
          cardinal_rel_eqpoll_rel_iff[THEN iffD1] by simp
      moreover
      note ‹D ⊆ {A-{p} . A∈{X∈G. p∈X}}›
      have "?D ⊆ G"
      proof -
        {
          fix A
          assume "A∈G" "p∈A"
          moreover from this
          have "A = A - {p} ∪ {p}"
            by blast
          ultimately
          have "A -{p} ∪ {p} ∈ G"
            by auto
        }
        with ‹D ⊆ {A-{p} . A∈{X∈G. p∈X}}›
        show ?thesis
          by blast
      qed
      moreover
      note ‹M(?D)›
      ultimately
      show "∃D[M]. D ⊆ G ∧ delta_system(D) ∧ D ≈⇗M⇖ ℵ⇘1⇙⇗M⇖" by auto
    next
      case False
      note ‹¬ (∃p[M]. {A ∈ G . p ∈ A} ≈⇗M⇖ ℵ⇘1⇙⇗M⇖)› ― ‹the other case›
        ‹M(G)› ‹⋀p. M(G) ⟹ M(p) ⟹ M({A∈G . p ∈ A})›
      moreover from ‹G ≈⇗M⇖ ℵ⇘1⇙⇗M⇖› and this
      have "M(p) ⟹ {A ∈ G . p ∈ A} ≲⇗M⇖ ℵ⇘1⇙⇗M⇖" (is "_ ⟹ ?G(p) ≲⇗M⇖ _") for p
        by (auto intro!:lepoll_rel_eq_trans[OF subset_imp_lepoll_rel] dest:transM)
      moreover from calculation
      have "M(p) ⟹ ?G(p) ≺⇗M⇖ ℵ⇘1⇙⇗M⇖" for p
        using ‹M(G) ⟹ M(p) ⟹ M({A∈G . p ∈ A})›
        unfolding lesspoll_rel_def by simp
      moreover from calculation
      have "M(p) ⟹ ?G(p) ≲⇗M⇖ ω" for p
        using lesspoll_rel_Aleph_rel_succ[of 0] Aleph_rel_zero by auto
      moreover
      have "{A ∈ G . S ∩ A ≠ 0} = (⋃p∈S. ?G(p))" for S
        by auto
      moreover from calculation
      have "M(S) ⟹ i ∈ S ⟹ M({x ∈ G . i ∈ x})" for i S
        by (auto dest: transM)
      moreover
      have "M(S) ⟹ countable_rel(M,S) ⟹ countable_rel(M,{A ∈ G . S ∩ A ≠ 0})" for S
      proof -
        from ‹M(G)›
        interpret M_replacement_lepoll M "λ_ x. Collect(G, (∈)(x))"
          using countable_lepoll_assms lam_replacement_inj_rel separation_in_rev
            lam_replacement_Collect[OF _ _ insnd_ball] mem_F_bound6[of _ G]
          by unfold_locales
            (auto dest:transM intro:lam_Least_assumption_general[of _  _ _ _ Union])
        fix S
        assume "M(S)"
        with ‹M(G)› ‹⋀i. M(S) ⟹ i ∈ S ⟹ M({x ∈ G . i ∈ x})›
        interpret M_cardinal_UN_lepoll _ ?G S
          using lepoll_assumptions
          by unfold_locales (auto dest:transM)
        assume "countable_rel(M,S)"
        with ‹M(S)› calculation(6) calculation(7,8)[of S]
        show "countable_rel(M,{A ∈ G . S ∩ A ≠ 0})"
          using InfCard_rel_nat Card_rel_nat
            le_Card_rel_iff[THEN iffD2, THEN [3] leqpoll_rel_imp_cardinal_rel_UN_le,
              THEN [4] le_Card_rel_iff[THEN iffD1], of ω] j.UN_closed
          unfolding countable_rel_def by (auto dest: transM)
      qed
      define Disjoint where "Disjoint = {<A,B> ∈ G×G . B ∩ A = 0}"
      have "Disjoint = {x ∈ G×G . ∃ a b. x=<a,b> ∧ a∩b=0}"
        unfolding Disjoint_def by force
      with ‹M(G)›
      have "M(Disjoint)"
        using disjoint_separation by simp
      text‹For every countable\_rel subfamily of term‹G› there is another some
      element disjoint from all of them:›
      have "∃A∈G. ∀S∈X. <S,A>∈Disjoint" if "|X|⇗M⇖ < ℵ⇘1⇙⇗M⇖" "X ⊆ G" "M(X)" for X
      proof -
        note ‹n∈ω› ‹M(G)›
        moreover from this and ‹⋀A. A∈G ⟹ |A|⇗M⇖ = succ(n)›
        have "|A|⇗M⇖= succ(n)" "M(A)" if "A∈G" for A
          using that Finite_cardinal_rel_eq_cardinal[of A] Finite_cardinal_rel_iff'[of A]
            nat_into_Finite transM[of A G] by (auto dest:transM)
        ultimately
        have "A∈G ⟹ Finite(A)" for A
          using cardinal_rel_Card_rel_eqpoll_rel_iff[of "succ(n)" A]
            Finite_cardinal_rel_eq_cardinal[of A] nat_into_Card_rel[of "succ(n)"]
            nat_into_M[of n] unfolding Finite_def eqpoll_rel_def by (auto)
        with ‹X⊆G› ‹M(X)›
        have "A∈X ⟹ countable_rel(M,A)" for A
          using Finite_imp_countable_rel by (auto dest: transM)
        moreover from ‹M(X)›
        have "M(⋃X)" by simp
        moreover
        note ‹|X|⇗M⇖ < ℵ⇘1⇙⇗M⇖› ‹M(X)›
        ultimately
        have "countable_rel(M,⋃X)"
          using Card_rel_nat[THEN cardinal_rel_lt_csucc_rel_iff, of X]
            countable_rel_union_countable_rel[of X]
            countable_rel_iff_cardinal_rel_le_nat[of X] Aleph_rel_succ
            Aleph_rel_zero by simp
        with ‹M(⋃X)› ‹M(_) ⟹ countable_rel(M,_) ⟹ countable_rel(M,{A ∈ G . _  ∩ A ≠ 0})›
        have "countable_rel(M,{A ∈ G . (⋃X) ∩ A ≠ 0})" by simp
        with ‹G ≈⇗M⇖ ℵ⇘1⇙⇗M⇖› ‹M(G)›
        obtain B where "B∈G" "B ∉ {A ∈ G . (⋃X) ∩ A ≠ 0}"
          using nat_lt_Aleph_rel1 cardinal_rel_Card_rel_eqpoll_rel_iff[of "ℵ⇘1⇙⇗M⇖" G]
            uncountable_rel_not_subset_countable_rel
            [of "{A ∈ G . (⋃X) ∩ A ≠ 0}" G]
            uncountable_rel_iff_nat_lt_cardinal_rel[of G]
          by force
        then
        have "∃A∈G. ∀S∈X. A ∩ S = 0" by auto
        with ‹X⊆G›
        show "∃A∈G. ∀S∈X. <S,A>∈Disjoint" unfolding Disjoint_def
          using subsetD by simp
      qed
      moreover from ‹G ≈⇗M⇖ ℵ⇘1⇙⇗M⇖› ‹M(G)›
      obtain b where "b∈G"
        using uncountable_rel_iff_subset_eqpoll_rel_Aleph_rel1
          uncountable_rel_not_empty by blast
      ultimately
      text‹Hence, the hypotheses to perform a bounded-cardinal selection
      are satisfied,›
      obtain S where "S:ℵ⇘1⇙⇗M⇖→⇗M⇖G" "α∈ℵ⇘1⇙⇗M⇖ ⟹ β∈ℵ⇘1⇙⇗M⇖ ⟹ α<β ⟹ <S`α, S`β> ∈Disjoint"
        for α β
        using bounded_cardinal_rel_selection[of "ℵ⇘1⇙⇗M⇖" G Disjoint] ‹M(Disjoint)›
        by force
      moreover from this ‹n∈ω› ‹M(G)›
      have inM:"M(S)" "M(n)" "⋀x. x ∈ ℵ⇘1⇙⇗M⇖ ⟹ S ` x ∈ G" "⋀x. x ∈ ℵ⇘1⇙⇗M⇖ ⟹ M(x)"
        using function_space_rel_char by (auto dest: transM)
      ultimately
      have "α ∈ ℵ⇘1⇙⇗M⇖ ⟹ β ∈ ℵ⇘1⇙⇗M⇖ ⟹ α≠β ⟹ S`α ∩ S`β = 0" for α β
        unfolding Disjoint_def
        using lt_neq_symmetry[of "ℵ⇘1⇙⇗M⇖" "λα β. S`α ∩ S`β = 0"] Card_rel_is_Ord
        by auto (blast)
      text‹and a symmetry argument shows that obtained term‹S› is
      an injective  term‹ℵ⇘1⇙⇗M⇖›-sequence of disjoint elements of term‹G›.›
      moreover from this and ‹⋀A. A∈G ⟹ |A|⇗M⇖ = succ(n)› inM
        ‹S : ℵ⇘1⇙⇗M⇖ →⇗M⇖ G› ‹M(G)›
      have "S ∈ inj_rel(M,ℵ⇘1⇙⇗M⇖, G)"
        using def_inj_rel[OF Aleph_rel_closed ‹M(G)›, of 1]
      proof (clarsimp)
        fix w x
        from inM
        have "a ∈ ℵ⇘1⇙⇗M⇖ ⟹ b ∈ ℵ⇘1⇙⇗M⇖ ⟹ a ≠ b ⟹ S ` a ≠ S ` b" for a b
          using ‹⋀A. A∈G ⟹ |A|⇗M⇖ = succ(n)›[THEN [4] cardinal_rel_succ_not_0[THEN [4]
                Int_eq_zero_imp_not_eq[OF calculation, of "ℵ⇘1⇙⇗M⇖" "λx. x"],
                of "λ_.n"], OF _ _ _ _ apply_closed] by auto
        moreover
        assume "w ∈ ℵ⇘1⇙⇗M⇖" "x ∈ ℵ⇘1⇙⇗M⇖" "S ` w = S ` x"
        ultimately
        show "w = x" by blast
      qed
      moreover from this ‹M(G)›
      have "range(S) ≈⇗M⇖ ℵ⇘1⇙⇗M⇖"
        using inj_rel_bij_rel_range eqpoll_rel_sym unfolding eqpoll_rel_def
        by (blast dest: transM)
      moreover
      note ‹M(G)›
      moreover from calculation
      have "range(S) ⊆ G"
        using inj_rel_is_fun range_fun_subset_codomain
        by (fastforce dest: transM)
      moreover
      note ‹M(S)›
      ultimately
      show "∃D[M]. D ⊆ G ∧ delta_system(D) ∧ D ≈⇗M⇖ ℵ⇘1⇙⇗M⇖"
        using inj_rel_is_fun ZF_Library.range_eq_image[of S "ℵ⇘1⇙⇗M⇖" G]
          image_function[OF fun_is_function, OF inj_rel_is_fun, of S "ℵ⇘1⇙⇗M⇖" G]
          domain_of_fun[OF inj_rel_is_fun, of S "ℵ⇘1⇙⇗M⇖" G] apply_replacement[of S]
        by (rule_tac x="S``ℵ⇘1⇙⇗M⇖" in rexI) (auto dest:transM intro!:RepFun_closed)
      text‹This finishes the successor case and hence the proof.›
    qed
  qed
  with ‹G ⊆ F›
  show ?thesis by blast
qed

lemma delta_system_uncountable_rel:
  assumes "∀A∈F. Finite(A)" "uncountable_rel(M,F)" "M(F)"
  shows "∃D[M]. D ⊆ F ∧ delta_system(D) ∧ D ≈⇗M⇖ ℵ⇘1⇙⇗M⇖"
proof -
  from assms
  obtain S where "S ⊆ F" "S ≈⇗M⇖ ℵ⇘1⇙⇗M⇖" "M(S)"
    using uncountable_rel_iff_subset_eqpoll_rel_Aleph_rel1[of F] by auto
  moreover from ‹∀A∈F. Finite(A)› and this
  have "∀A∈S. Finite(A)" by auto
  ultimately
  show ?thesis using delta_system_Aleph_rel1[of S]
    by (auto dest:transM)
qed

end ― ‹locale‹M_delta››

end
>

Theory Pointed_DC_Relative

section‹Relative DC›

theory Pointed_DC_Relative
  imports
    Cardinal_Library_Relative

begin

consts dc_witness :: "i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i"
primrec
  wit0   : "dc_witness(0,A,a,s,R) = a"
  witrec : "dc_witness(succ(n),A,a,s,R) = s`{x∈A. ⟨dc_witness(n,A,a,s,R),x⟩∈R}"

lemmas dc_witness_def = dc_witness_nat_def

relativize functional "dc_witness" "dc_witness_rel"
relationalize "dc_witness_rel" "is_dc_witness"
  (* definition
  is_dc_witness_fm where
  "is_dc_witness_fm(na, A, a, s, R, e) ≡ is_transrec_fm
                  (is_nat_case_fm
                    (a +ω 8, (⋅∃⋅⋅4`2 is 0⋅ ∧ (⋅∃⋅⋅s +ω 12`0 is 2⋅ ∧ Collect_fm(A +ω 12, ⋅(⋅∃⋅0 = 0⋅⋅) ∧ (⋅∃⋅⋅0 ∈ R +ω 14⋅ ∧ pair_fm(3, 1, 0) ⋅⋅)⋅, 0) ⋅⋅)⋅⋅), 2,
                     0), na, e)"
 *)
schematic_goal sats_is_dc_witness_fm_auto:
  assumes "na < length(env)" "e < length(env)"
  shows
    "   na ∈ ω ⟹
    A ∈ ω ⟹
    a ∈ ω ⟹
    s ∈ ω ⟹
    R ∈ ω ⟹
    e ∈ ω ⟹
    env ∈ list(Aa) ⟹
    0 ∈ Aa ⟹
    is_dc_witness(##Aa, nth(na, env), nth(A, env), nth(a, env), nth(s, env), nth(R, env), nth(e, env)) ⟷
    Aa, env ⊨ ?fm(nat, A, a, s, R, e)"
  unfolding is_dc_witness_def is_recursor_def
  by (rule is_transrec_iff_sats | simp_all)
    (rule iff_sats is_nat_case_iff_sats is_eclose_iff_sats sep_rules | simp add:assms)+

synthesize "is_dc_witness" from_schematic

manual_arity for "is_dc_witness_fm"
  unfolding is_dc_witness_fm_def apply (subst arity_transrec_fm)
       apply (simp add:arity) defer 3
      apply (simp add:arity) defer
     apply (subst arity_is_nat_case_fm)
           apply (simp add:arity del:arity_transrec_fm) prefer 5
  by (simp add:arity del:arity_transrec_fm)+

definition dcwit_body :: "[i,i,i,i,i] ⇒ o" where
  "dcwit_body(A,a,g,R) ≡ λp. snd(p) = dc_witness(fst(p), A, a, g, R)"

relativize functional "dcwit_body" "dcwit_body_rel"
relationalize "dcwit_body_rel" "is_dcwit_body"

synthesize "is_dcwit_body" from_definition assuming "nonempty"
arity_theorem for "is_dcwit_body_fm"

context M_replacement
begin

lemma dc_witness_closed[intro,simp]:
  assumes "M(n)" "M(A)" "M(a)" "M(s)" "M(R)" "n∈nat"
  shows "M(dc_witness(n,A,a,s,R))"
  using ‹n∈nat›
proof(induct)
  case 0
  with ‹M(a)›
  show ?case
    unfolding dc_witness_def by simp
next
  case (succ x)
  with assms
  have "M(dc_witness(x,A,a,s,R))" (is "M(?b)")
    by simp
  moreover from this assms
  have "M(({?b}×A)∩R)" (is "M(?X)") by auto
  moreover
  have "{x∈A. ⟨?b,x⟩∈R} = {snd(y) . y∈?X}" (is "_ = ?Y")
    by(intro equalityI subsetI,force,auto)
  moreover from calculation
  have "M(?Y)"
    using lam_replacement_snd lam_replacement_imp_strong_replacement RepFun_closed
      snd_closed[OF transM]
    by auto
  ultimately
  show ?case
    using ‹M(s)› apply_closed
    unfolding dc_witness_def by simp
qed

lemma dc_witness_rel_char:
  assumes "M(A)"
  shows "dc_witness_rel(M,n,A,a,s,R) = dc_witness(n,A,a,s,R)"
proof -
  from assms
  have "{x ∈ A . ⟨rec, x⟩ ∈ R} =  {x ∈ A . M(x) ∧ ⟨rec, x⟩ ∈ R}" for rec
    by (auto dest:transM)
  then
  show ?thesis
    unfolding dc_witness_def dc_witness_rel_def by simp
qed

lemma (in M_basic) first_section_closed:
  assumes
    "M(A)" "M(a)" "M(R)"
  shows "M({x ∈ A . ⟨a, x⟩ ∈ R})"
proof -
  have "{x ∈ A . ⟨a, x⟩ ∈ R} = range({a} × range(R) ∩ R) ∩ A"
    by (intro equalityI) auto
  with assms
  show ?thesis
    by simp
qed

lemma witness_into_A [TC]:
  assumes "a∈A"
    "∀X[M]. X≠0 ∧ X⊆A ⟶ s`X∈A"
    "∀y∈A. {x∈A. ⟨y,x⟩∈R } ≠ 0" "n∈nat"
    "M(A)" "M(a)" "M(s)" "M(R)"
  shows "dc_witness(n, A, a, s, R)∈A"
  using ‹n∈nat›
proof(induct n)
  case 0
  then show ?case using ‹a∈A› by simp
next
  case (succ x)
  with succ assms(1,3-)
  show ?case
    using nat_into_M first_section_closed
    by (simp, rule_tac rev_subsetD, rule_tac assms(2)[rule_format])
      auto
qed

end ― ‹locale‹M_replacement››

locale M_DC = M_trancl + M_replacement + M_eclose +
  assumes
    separation_is_dcwit_body:
    "M(A) ⟹ M(a) ⟹ M(g) ⟹ M(R) ⟹ separation(M,is_dcwit_body(M, A, a, g, R))"
    and
    dcwit_replacement:"Ord(na) ⟹
    M(na) ⟹
    M(A) ⟹
    M(a) ⟹
    M(s) ⟹
    M(R) ⟹
    transrec_replacement
     (M, λn f ntc.
            is_nat_case
             (M, a,
              λm bmfm.
                 ∃fm[M]. ∃cp[M].
                    is_apply(M, f, m, fm) ∧
                    is_Collect(M, A, λx. ∃fmx[M]. (M(x) ∧ fmx ∈ R) ∧ pair(M, fm, x, fmx), cp) ∧
                    is_apply(M, s, cp, bmfm),
              n, ntc),na)"
begin

lemma is_dc_witness_iff:
  assumes "Ord(na)" "M(na)" "M(A)" "M(a)" "M(s)" "M(R)" "M(res)"
  shows "is_dc_witness(M, na, A, a, s, R, res) ⟷ res = dc_witness_rel(M, na, A, a, s, R)"
proof -
  note assms
  moreover from this
  have "{x ∈ A . M(x) ∧ ⟨f, x⟩ ∈ R} = {x ∈ A . ⟨f, x⟩ ∈ R}" for f
    by (auto dest:transM)
  moreover from calculation
  have "M(fm) ⟹ M({x ∈ A . M(x) ∧ ⟨fm, x⟩ ∈ R})" for fm
    using first_section_closed by (auto dest:transM)
  moreover from calculation
  have "M(x) ⟹ M(z) ⟹ M(mesa) ⟹
    (∃ya[M]. pair(M, x, ya, z) ∧
      is_wfrec(M, λn f. is_nat_case(M, a, λm bmfm. ∃fm[M]. is_apply(M, f, m, fm) ∧
        is_apply(M, s, {x ∈ A . ⟨fm, x⟩ ∈ R}, bmfm), n), mesa, x, ya))
    ⟷
    (∃y[M]. pair(M, x, y, z) ∧
      is_wfrec(M, λn f. is_nat_case(M, a,
        λm bmfm.
          ∃fm[M]. ∃cp[M]. is_apply(M, f, m, fm) ∧
            is_Collect(M, A, λx. M(x) ∧ ⟨fm, x⟩ ∈ R, cp) ∧  is_apply(M, s, cp, bmfm),n),
        mesa, x, y))" for x z mesa by simp
  moreover from calculation
  show ?thesis
    using assms dcwit_replacement[of na A a s R]
    unfolding is_dc_witness_def dc_witness_rel_def
    by (rule_tac recursor_abs) (auto dest:transM)
qed

lemma dcwit_body_abs:
  "fst(x) ∈ ω ⟹ M(A) ⟹ M(a) ⟹ M(g) ⟹ M(R) ⟹ M(x) ⟹
   is_dcwit_body(M,A,a,g,R,x) ⟷ dcwit_body(A,a,g,R,x)"
  using pair_in_M_iff apply_closed transM[of _ A]
    is_dc_witness_iff[of "fst(x)" "A" "a" "g" "R" "snd(x)"]
    fst_snd_closed dc_witness_closed
  unfolding dcwit_body_def is_dcwit_body_def
  by (auto dest:transM simp:absolut dc_witness_rel_char del:bexI intro!:bexI)

lemma separation_eq_dc_witness:
  "M(A) ⟹
    M(a) ⟹
    M(g) ⟹
    M(R) ⟹  separation(M,λp. fst(p)∈ω ⟶ snd(p) = dc_witness(fst(p), A, a, g, R))"
  using separation_is_dcwit_body dcwit_body_abs unfolding is_dcwit_body_def
  oops

lemma Lambda_dc_witness_closed:
  assumes "g ∈ Pow⇗M⇖(A)-{0} → A" "a∈A" "∀y∈A. {x ∈ A . ⟨y, x⟩ ∈ R} ≠ 0"
    "M(g)" "M(A)" "M(a)" "M(R)"
  shows "M(λn∈nat. dc_witness(n,A,a,g,R))"
proof -
  from assms
  have "(λn∈nat. dc_witness(n,A,a,g,R)) = {p ∈ ω × A . is_dcwit_body(M,A,a,g,R,p)}"
    using witness_into_A[of a A g R]
      Pow_rel_char apply_type[of g "{x ∈ Pow(A) . M(x)}-{0}" "λ_.A"]
    unfolding lam_def split_def
    apply (intro equalityI subsetI)
     apply (auto) (* slow *)
    by (subst dcwit_body_abs, simp_all add:transM[of _ ω] dcwit_body_def,
        subst (asm) dcwit_body_abs, auto dest:transM simp:dcwit_body_def)
      (* by (intro equalityI subsetI, auto) (* Extremely slow *)
    (subst dcwit_body_abs, simp_all add:transM[of _ ω] dcwit_body_def,
      subst (asm) dcwit_body_abs, auto dest:transM simp:dcwit_body_def) *)
  with assms
  show ?thesis
    using separation_is_dcwit_body dc_witness_rel_char unfolding split_def by simp
qed

lemma witness_related:
  assumes "a∈A"
    "∀X[M]. X≠0 ∧ X⊆A ⟶ s`X∈X"
    "∀y∈A. {x∈A. ⟨y,x⟩∈R } ≠ 0" "n∈nat"
    "M(a)" "M(A)" "M(s)" "M(R)" "M(n)"
  shows "⟨dc_witness(n, A, a, s, R),dc_witness(succ(n), A, a, s, R)⟩∈R"
proof -
  note assms
  moreover from this
  have "(∀X[M]. X≠0 ∧ X⊆A ⟶ s`X∈A)" by auto
  moreover from calculation
  have "dc_witness(n, A, a, s, R)∈A" (is "?x ∈ A")
    using witness_into_A[of _ _ s R n] by simp
  moreover from assms
  have "M({x ∈ A . ⟨dc_witness(n, A, a, s, R), x⟩ ∈ R})"
    using first_section_closed[of A "dc_witness(n, A, a, s, R)"]
    by simp
  ultimately
  show ?thesis by auto
qed

lemma witness_funtype:
  assumes "a∈A"
    "∀X[M]. X≠0 ∧ X⊆A ⟶ s`X ∈ A"
    "∀y∈A. {x∈A. ⟨y,x⟩∈R} ≠ 0"
    "M(A)" "M(a)" "M(s)" "M(R)"
  shows "(λn∈nat. dc_witness(n, A, a, s, R)) ∈ nat → A" (is "?f ∈ _ → _")
proof -
  have "?f ∈ nat → {dc_witness(n, A, a, s, R). n∈nat}" (is "_ ∈ _ → ?B")
    using lam_funtype assms by simp
  then
  have "?B ⊆ A"
    using witness_into_A assms by auto
  with ‹?f ∈ _›
  show ?thesis
    using fun_weaken_type
    by simp
qed

lemma witness_to_fun:
  assumes "a∈A"
    "∀X[M]. X≠0 ∧ X⊆A ⟶ s`X∈A"
    "∀y∈A. {x∈A. ⟨y,x⟩∈R } ≠ 0"
    "M(A)" "M(a)" "M(s)" "M(R)"
  shows "∃f ∈ nat→A. ∀n∈nat. f`n =dc_witness(n,A,a,s,R)"
  using assms bexI[of _ "λn∈nat. dc_witness(n,A,a,s,R)"] witness_funtype
  by simp

end ― ‹locale‹M_DC››

locale M_library_DC = M_library + M_DC
begin

(* Should port the whole AC theory, including the absolute version
  of the following theorem *)
lemma AC_M_func:
  assumes "⋀x. x ∈ A ⟹ (∃y. y ∈ x)" "M(A)"
  shows "∃f ∈ A →⇗M⇖ ⋃(A). ∀x ∈ A. f`x ∈ x"
proof -
  from ‹M(A)›
  interpret mpiA:M_Pi_assumptions _ A "λx. x"
    using Pi_replacement Pi_separation lam_replacement_identity
      lam_replacement_Sigfun[THEN lam_replacement_imp_strong_replacement]
    by unfold_locales (simp_all add:transM[of _ A])
  from ‹M(A)›
  interpret mpic_A:M_Pi_assumptions_choice _ A "λx. x"
    apply unfold_locales
    using lam_replacement_constant lam_replacement_identity
      lam_replacement_identity[THEN lam_replacement_imp_strong_replacement]
      lam_replacement_minimum[THEN [5] lam_replacement_hcomp2]
    unfolding lam_replacement_def[symmetric]
    by auto
  from ‹M(A)›
  interpret mpi2:M_Pi_assumptions2 _ A "λ_. ⋃A" "λx. x"
    using Pi_replacement Pi_separation lam_replacement_constant
      lam_replacement_Sigfun[THEN lam_replacement_imp_strong_replacement,
        of  "λ_. ⋃A"] Pi_replacement1[of _  "⋃A"] transM[of _  "A"]
    by unfold_locales auto
  from assms
  show ?thesis
    using mpi2.Pi_rel_type apply_type mpiA.mem_Pi_rel_abs mpi2.mem_Pi_rel_abs
      function_space_rel_char
    by (rule_tac mpic_A.AC_Pi_rel[THEN rexE], simp, rule_tac x=x in bexI)
      (auto, rule_tac C="λx. x" in Pi_type, auto)
qed

lemma non_empty_family: "[| 0 ∉ A;  x ∈ A |] ==> ∃y. y ∈ x"
  by (subgoal_tac "x ≠ 0", blast+)

lemma AC_M_func0: "0 ∉ A ⟹ M(A) ⟹ ∃f ∈ A →⇗M⇖ ⋃(A). ∀x ∈ A. f`x ∈ x"
  by (rule AC_M_func) (simp_all add: non_empty_family)

lemma AC_M_func_Pow_rel:
  assumes "M(C)"
  shows "∃f ∈ (Pow⇗M⇖(C)-{0}) →⇗M⇖ C. ∀x ∈ Pow⇗M⇖(C)-{0}. f`x ∈ x"
proof -
  have "0∉Pow⇗M⇖(C)-{0}" by simp
  with assms
  obtain f where "f ∈ (Pow⇗M⇖(C)-{0}) →⇗M⇖ ⋃(Pow⇗M⇖(C)-{0})" "∀x ∈ Pow⇗M⇖(C)-{0}. f`x ∈ x"
    using AC_M_func0[OF ‹0∉_›] by auto
  moreover
  have "x⊆C" if "x ∈ Pow⇗M⇖(C) - {0}" for x
    using that Pow_rel_char assms
    by auto
  moreover
  have "⋃(Pow⇗M⇖(C) - {0}) ⊆ C"
    using assms Pow_rel_char by auto
  ultimately
  show ?thesis
    using assms function_space_rel_char
    by (rule_tac bexI,auto,rule_tac Pi_weaken_type,simp_all)
qed

theorem pointed_DC:
  assumes "∀x∈A. ∃y∈A. ⟨x,y⟩∈ R" "M(A)" "M(R)"
  shows "∀a∈A. ∃f ∈ nat→⇗M⇖ A. f`0 = a ∧ (∀n ∈ nat. ⟨f`n,f`succ(n)⟩∈R)"
proof -
  have 0:"∀y∈A. {x ∈ A . ⟨y, x⟩ ∈ R} ≠ 0"
    using assms by auto
  from ‹M(A)›
  obtain g where 1: "g ∈ Pow⇗M⇖(A)-{0} → A" "∀X[M]. X ≠ 0 ∧ X ⊆ A ⟶ g ` X ∈ X"
    "M(g)"
    using AC_M_func_Pow_rel[of A] mem_Pow_rel_abs
      function_space_rel_char[of "Pow⇗M⇖(A)-{0}" A] by auto
  then
  have 2:"∀X[M]. X ≠ 0 ∧ X ⊆ A ⟶ g ` X ∈ A" by auto
  {
    fix a
    assume "a∈A"
    let ?f ="λn∈nat. dc_witness(n,A,a,g,R)"
    note ‹a∈A›
    moreover from this
    have f0: "?f`0 = a" by simp
    moreover
    note ‹a∈A› ‹M(g)› ‹M(A)› ‹M(R)›
    moreover from calculation
    have "⟨?f ` n, ?f ` succ(n)⟩ ∈ R" if "n∈nat" for n
      using witness_related[OF ‹a∈A› _ 0, of g n] 1 that
      by (auto dest:transM)
    ultimately
    have "∃f[M]. f∈nat → A ∧ f ` 0 = a ∧ (∀n∈nat. ⟨f ` n, f ` succ(n)⟩ ∈ R)"
      using 0 1 ‹a∈_›
      by (rule_tac x="(λn∈ω. dc_witness(n, A, a, g, R))" in rexI)
        (simp_all, rule_tac witness_funtype,
          auto intro!: Lambda_dc_witness_closed dest:transM)
  }
  with ‹M(A)›
  show ?thesis using function_space_rel_char by auto
qed

lemma aux_DC_on_AxNat2 : "∀x∈A×nat. ∃y∈A. ⟨x,⟨y,succ(snd(x))⟩⟩ ∈ R ⟹
                  ∀x∈A×nat. ∃y∈A×nat. ⟨x,y⟩ ∈ {⟨a,b⟩∈R. snd(b) = succ(snd(a))}"
  by (rule ballI, erule_tac x="x" in ballE, simp_all)

lemma infer_snd : "c∈ A×B ⟹ snd(c) = k ⟹ c=⟨fst(c),k⟩"
  by auto

corollary DC_on_A_x_nat :
  assumes "(∀x∈A×nat. ∃y∈A. ⟨x,⟨y,succ(snd(x))⟩⟩ ∈ R)" "a∈A" "M(A)" "M(R)"
  shows "∃f ∈ nat→⇗M⇖A. f`0 = a ∧ (∀n ∈ nat. ⟨⟨f`n,n⟩,⟨f`succ(n),succ(n)⟩⟩∈R)" (is "∃x∈_.?P(x)")
proof -
  let ?R'="{⟨a,b⟩∈R. snd(b) = succ(snd(a))}"
  from assms(1)
  have "∀x∈A×nat. ∃y∈A×nat. ⟨x,y⟩ ∈ ?R'"
    using aux_DC_on_AxNat2 by simp
  moreover
  note ‹a∈_› ‹M(A)›
  moreover from this
  have "M(A × ω)" by simp
  have "lam_replacement(M, λx. succ(snd(fst(x))))"
    using lam_replacement_fst lam_replacement_snd lam_replacement_hcomp
      lam_replacement_hcomp[of _ "λx. succ(snd(x))"]
      lam_replacement_succ by simp
  with ‹M(R)›
  have "M(?R')"
    using separation_eq lam_replacement_fst lam_replacement_snd
      lam_replacement_succ lam_replacement_hcomp lam_replacement_identity
    unfolding split_def by simp
  ultimately
  obtain f where
    F:"f∈nat→⇗M⇖ A×ω" "f ` 0 = ⟨a,0⟩"  "∀n∈nat. ⟨f ` n, f ` succ(n)⟩ ∈ ?R'"
    using pointed_DC[of "A×nat" ?R'] by blast
  with ‹M(A)›
  have "M(f)" using function_space_rel_char by simp
  then
  have "M(λx∈nat. fst(f`x))" (is "M(?f)")
    using lam_replacement_fst lam_replacement_hcomp
      lam_replacement_constant lam_replacement_identity
      lam_replacement_apply
    by (rule_tac lam_replacement_iff_lam_closed[THEN iffD1, rule_format])
      auto
  with F ‹M(A)›
  have "?f∈nat→⇗M⇖ A" "?f ` 0 = a" using function_space_rel_char by auto
  have 1:"n∈ nat ⟹ f`n= ⟨?f`n, n⟩" for n
  proof(induct n set:nat)
    case 0
    then show ?case using F by simp
  next
    case (succ x)
    with ‹M(A)›
    have "⟨f`x, f`succ(x)⟩ ∈ ?R'" "f`x ∈ A×nat" "f`succ(x)∈A×nat"
      using F function_space_rel_char[of ω "A×ω"] by auto
    then
    have "snd(f`succ(x)) = succ(snd(f`x))" by simp
    with succ ‹f`x∈_›
    show ?case using infer_snd[OF ‹f`succ(_)∈_›] by auto
  qed
  have "⟨⟨?f`n,n⟩,⟨?f`succ(n),succ(n)⟩⟩ ∈ R" if "n∈nat" for n
    using that 1[of "succ(n)"] 1[OF ‹n∈_›] F(3) by simp
  with ‹f`0=⟨a,0⟩›
  show ?thesis
    using rev_bexI[OF ‹?f∈_›] by simp
qed

lemma aux_sequence_DC :
  assumes "∀x∈A. ∀n∈nat. ∃y∈A. ⟨x,y⟩ ∈ S`n"
    "R={⟨⟨x,n⟩,⟨y,m⟩⟩ ∈ (A×nat)×(A×nat). ⟨x,y⟩∈S`m }"
  shows "∀ x∈A×nat . ∃y∈A. ⟨x,⟨y,succ(snd(x))⟩⟩ ∈ R"
  using assms Pair_fst_snd_eq by auto

lemma aux_sequence_DC2 : "∀x∈A. ∀n∈nat. ∃y∈A. ⟨x,y⟩ ∈ S`n ⟹
        ∀x∈A×nat. ∃y∈A. ⟨x,⟨y,succ(snd(x))⟩⟩ ∈ {⟨⟨x,n⟩,⟨y,m⟩⟩∈(A×nat)×(A×nat). ⟨x,y⟩∈S`m }"
  by auto

lemma sequence_DC:
  assumes "∀x∈A. ∀n∈nat. ∃y∈A. ⟨x,y⟩ ∈ S`n" "M(A)" "M(S)"
  shows "∀a∈A. (∃f ∈ nat→⇗M⇖ A. f`0 = a ∧ (∀n ∈ nat. ⟨f`n,f`succ(n)⟩∈S`succ(n)))"
proof -
  from ‹M(S)›
  have "lam_replacement(M, λx. S ` snd(snd(x)))"
    using lam_replacement_snd lam_replacement_hcomp
      lam_replacement_hcomp[of _ "λx. S`snd(x)"] lam_replacement_apply by simp
  with assms
  have "M({x ∈ (A × ω) × A × ω . (λ⟨⟨x,n⟩,y,m⟩. ⟨x, y⟩ ∈ S ` m)(x)})"
    using lam_replacement_fst lam_replacement_snd
      lam_replacement_Pair[THEN [5] lam_replacement_hcomp2,
        of "λx. fst(fst(x))" "λx. fst(snd(x))", THEN [2] separation_in,
        of "λx. S ` snd(snd(x))"] lam_replacement_apply[of S]
      lam_replacement_hcomp unfolding split_def by simp
  with assms
  show ?thesis
    by (rule_tac ballI) (drule aux_sequence_DC2, drule DC_on_A_x_nat, auto)
qed

end ― ‹locale‹M_library_DC››

end

Theory Partial_Functions_Relative

section‹Cohen forcing notions›

theory Partial_Functions_Relative
  imports
    Cardinal_Library_Relative
begin

text‹In this theory we introduce bounded partial functions and its relative
version; for historical reasons the relative version is based on a proper
definition of partial functions.

We note that finite partial functions are easier and are used to prove
some lemmas about finite sets in the theory
theory‹Transitive_Models.ZF_Library_Relative›.›

definition
  Fn :: "[i,i,i] ⇒ i" where
  "Fn(κ,I,J) ≡ ⋃{y . d ∈ Pow(I), y=(d→J) ∧ d≺κ}"

lemma domain_function_lepoll :
  assumes "function(r)"
  shows "domain(r) ≲ r"
proof -
  let ?f="λx∈domain(r) . <x,THE y . <x,y> ∈ r>"
  have 1:"⋀x. x ∈ domain(r) ⟹ ∃!y. <x,y> ∈ r"
    using assms unfolding domain_def function_def by auto
  then
  have "?f ∈ inj(domain(r), r)"
    using theI[OF 1]
    by(rule_tac lam_injective,auto)
  then
  show ?thesis unfolding lepoll_def
    by force
qed

lemma function_lepoll:
  assumes "r:d→J"
  shows "r ≲ d"
proof -
  let ?f="λx∈r . fst(x)"
  note assms Pi_iff[THEN iffD1,OF assms]
  moreover from this
  have 1:"⋀x. x ∈ domain(r) ⟹ ∃!y. <x,y> ∈ r"
    unfolding function_def by auto
  moreover from calculation
  have "(THE u . <fst(x),u> ∈ r) = snd(x)" if "x∈r" for x
    using that subsetD[of r "d×J" x] theI[OF 1]
    by(auto,rule_tac the_equality2[OF 1],auto)
  moreover from calculation
  have "⋀x. x ∈r ⟹ <fst(x),THE y . <fst(x),y> ∈ r> = x"
    by auto
  ultimately
  have "?f∈inj(r,d)"
    by(rule_tac d= "λu . <u,THE y . <u,y> ∈ r>" in lam_injective,force,simp)
  then
  show ?thesis
    unfolding lepoll_def
    by auto
qed

lemma function_eqpoll :
  assumes "r:d→J"
  shows "r ≈ d"
  using assms domain_of_fun domain_function_lepoll Pi_iff[THEN iffD1,OF assms]
    eqpollI[OF function_lepoll[OF assms]] subset_imp_lepoll
  by force

lemma Fn_char : "Fn(κ,I,J) = {f ∈ Pow(I×J) . function(f) ∧ f ≺ κ}" (is "?L=?R")
proof (intro equalityI subsetI)
  fix x
  assume "x ∈ ?R"
  moreover from this
  have "domain(x) ∈ Pow(I)" "domain(x) ≲ x" "x≺ κ"
    using domain_function_lepoll
    by auto
  ultimately
  show "x ∈ ?L"
    unfolding Fn_def
    using lesspoll_trans1 Pi_iff
    by (auto,rule_tac rev_bexI[of "domain(x) → J"],auto)
next
  fix x
  assume "x ∈ ?L"
  then
  obtain d where "x:d→J" "d ∈ Pow(I)" "d≺κ"
    unfolding Fn_def
    by auto
  moreover from this
  have "x≺κ"
    using function_lepoll[THEN lesspoll_trans1] by auto
  moreover from calculation
  have "x ∈ Pow(I×J)" "function(x)"
    using Pi_iff by auto
  ultimately
  show "x ∈ ?R" by simp
qed

lemma zero_in_Fn:
  assumes "0 < κ"
  shows "0 ∈ Fn(κ, I, J)"
  using lt_Card_imp_lesspoll assms zero_lesspoll
  unfolding Fn_def
  by (simp,rule_tac x="0→J" in bexI,simp)
    (rule ReplaceI[of _ 0],simp_all)

lemma Fn_nat_eq_FiniteFun: "Fn(nat,I,J) = I -||> J"
proof (intro equalityI subsetI)
  fix x
  assume "x ∈ I -||> J"
  then
  show "x ∈ Fn(nat,I,J)"
  proof (induct)
    case emptyI
    then
    show ?case
      using zero_in_Fn ltI
      by simp
  next
    case (consI a b h)
    then
    obtain d where "h:d→J" "d≺nat" "d⊆I"
      unfolding Fn_def by auto
    moreover from this
    have "Finite(d)"
      using lesspoll_nat_is_Finite by simp
    ultimately
    have "h : d -||> J"
      using fun_FiniteFunI Finite_into_Fin by blast
    note ‹h:d→J›
    moreover from this
    have "domain(cons(⟨a, b⟩, h)) = cons(a,d)" (is "domain(?h) = ?d")
      and "domain(h) = d"
      using domain_of_fun by simp_all
    moreover
    note consI
    moreover from calculation
    have "cons(⟨a, b⟩, h) ∈ cons(a,d) → J"
      using fun_extend3 by simp
    moreover from ‹Finite(d)›
    have "Finite(cons(a,d))" by simp
    moreover from this
    have "cons(a,d) ≺ nat" using Finite_imp_lesspoll_nat by simp
    ultimately
    show ?case
      unfolding Fn_def
      by (simp,rule_tac x="?d→J" in bexI)
        (force dest:app_fun)+
  qed
next
  fix x
  assume "x ∈ Fn(nat,I,J)"
  then
  obtain d where "x:d→J" "d ∈ Pow(I)" "d≺nat"
    unfolding Fn_def
    by auto
  moreover from this
  have "Finite(d)"
    using lesspoll_nat_is_Finite by simp
  moreover from calculation
  have "d ∈ Fin(I)"
    using Finite_into_Fin[of d] Fin_mono by auto
  ultimately
  show "x ∈ I -||> J" using fun_FiniteFunI FiniteFun_mono by blast
qed

lemma Fn_nat_subset_Pow: "Fn(κ,I,J) ⊆ Pow(I×J)"
  using Fn_char by auto

lemma FnI:
  assumes "p : d → J" "d ⊆ I" "d ≺ κ"
  shows "p ∈ Fn(κ,I,J)"
  using assms
  unfolding Fn_def by auto

lemma FnD[dest]:
  assumes "p ∈ Fn(κ,I,J)"
  shows "∃d. p : d → J ∧ d ⊆ I ∧ d ≺ κ"
  using assms
  unfolding Fn_def by auto

lemma Fn_is_function: "p ∈ Fn(κ,I,J) ⟹ function(p)"
  unfolding Fn_def using fun_is_function by auto

lemma Fn_csucc:
  assumes "Ord(κ)"
  shows "Fn(csucc(κ),I,J) = ⋃{y . d ∈ Pow(I), y=(d→J) ∧ d≲κ}"
  using assms
  unfolding Fn_def using lesspoll_csucc by (simp)

definition
  FnleR :: "i ⇒ i ⇒ o" (infixl ‹⊇› 50) where
  "f ⊇ g ≡ g ⊆ f"

lemma FnleR_iff_subset [iff]: "f ⊇ g ⟷ g ⊆ f"
  unfolding FnleR_def ..

definition
  Fnlerel :: "i ⇒ i" where
  "Fnlerel(A) ≡ Rrel(λx y. x ⊇ y,A)"

definition
  Fnle :: "[i,i,i] ⇒ i" where
  "Fnle(κ,I,J) ≡ Fnlerel(Fn(κ,I,J))"

lemma FnleI[intro]:
  assumes "p ∈ Fn(κ,I,J)" "q ∈ Fn(κ,I,J)" "p ⊇ q"
  shows "⟨p,q⟩ ∈ Fnle(κ,I,J)"
  using assms unfolding Fnlerel_def Fnle_def FnleR_def Rrel_def
  by auto

lemma FnleD[dest]:
  assumes "⟨p,q⟩ ∈ Fnle(κ,I,J)"
  shows "p ∈ Fn(κ,I,J)" "q ∈ Fn(κ,I,J)" "p ⊇ q"
  using assms unfolding Fnlerel_def Fnle_def FnleR_def Rrel_def
  by auto

definition PFun_Space_Rel :: "[i,i⇒o, i] ⇒ i"  ("_⇀⇗_⇖_")
  where "A ⇀⇗M⇖ B ≡ {f ∈ Pow(A×B) . M(f) ∧ function(f)}"

lemma (in M_library) PFun_Space_subset_Powrel :
  assumes "M(A)" "M(B)"
  shows "A ⇀⇗M⇖ B = {f ∈ Pow⇗M⇖(A×B) . function(f)}"
  using Pow_rel_char assms
  unfolding PFun_Space_Rel_def
  by auto

lemma (in M_library) PFun_Space_closed :
  assumes "M(A)" "M(B)"
  shows "M(A ⇀⇗M⇖ B)"
  using assms PFun_Space_subset_Powrel separation_is_function
  by auto

lemma Un_filter_fun_space_closed:
  assumes "G ⊆ I → J" "⋀ f g . f∈G ⟹ g∈G ⟹ ∃d∈I→ J . d ⊇ f ∧ d ⊇ g"
  shows "⋃G ∈ Pow(I×J)" "function(⋃G)"
proof -
  from assms
  show "⋃G ∈ Pow(I×J)"
    using Union_Pow_iff
    unfolding Pi_def
    by auto
next
  show "function(⋃G)"
    unfolding function_def
  proof(auto)
    fix B B' x y y'
    assume "B ∈ G" "⟨x, y⟩ ∈ B" "B' ∈ G" "⟨x, y'⟩ ∈ B'"
    moreover from assms this
    have "B ∈ I → J" "B' ∈ I → J"
      by auto
    moreover from calculation assms(2)[of B B']
    obtain d where "d ⊇ B"  "d ⊇ B'" "d∈I → J"  "⟨x, y⟩ ∈ d" "⟨x, y'⟩ ∈ d"
      using subsetD[OF ‹G⊆_›]
      by auto
    then
    show "y=y'"
      using fun_is_function[OF ‹d∈_›]
      unfolding function_def
      by force
  qed
qed

lemma Un_filter_is_fun :
  assumes "G ⊆ I → J" "⋀ f g . f∈G ⟹ g∈G ⟹ ∃d∈I→ J . d⊇f ∧ d⊇g" "G≠0"
  shows "⋃G ∈ I → J"
  using assms Un_filter_fun_space_closed Pi_iff
proof(simp_all)
  show "I⊆domain(⋃G)"
  proof -
    from ‹G≠0›
    obtain f where "f⊆⋃G" "f∈G"
      by auto
    with ‹G⊆_›
    have "f∈I→J" by auto
    then
    show ?thesis
      using subset_trans[OF _ domain_mono[OF ‹f⊆⋃G›],of I]
      unfolding Pi_def by auto
  qed
qed

context M_cardinals
begin

lemma mem_function_space_relD:
  assumes "f ∈ function_space_rel(M,A,y)" "M(A)" "M(y)"
  shows "f ∈ A → y" and "M(f)"
  using assms function_space_rel_char by simp_all

lemma pfunI :
  assumes "C⊆A" "f ∈ C →⇗M⇖ B" "M(C)" "M(B)"
  shows "f∈ A ⇀⇗M⇖ B"
proof -
  from assms
  have "f ∈ C→B" "M(f)"
    using mem_function_space_relD
    by simp_all
  with assms
  show ?thesis
    using Pi_iff
    unfolding PFun_Space_Rel_def
    by auto
qed

lemma zero_in_PFun_rel:
  assumes "M(I)" "M(J)"
  shows "0 ∈ I ⇀⇗M⇖ J"
  using pfunI[of 0] nonempty mem_function_space_rel_abs assms
  by simp

lemma pfun_subsetI :
  assumes "f ∈ A ⇀⇗M⇖ B" "g⊆f" "M(g)"
  shows "g∈ A ⇀⇗M⇖ B"
  using assms function_subset
  unfolding PFun_Space_Rel_def
  by auto

lemma pfun_is_function :
  "f ∈ A⇀⇗M⇖ B ⟹ function(f)"
  unfolding PFun_Space_Rel_def by simp

lemma pfun_Un_filter_closed:
  assumes "G ⊆I⇀⇗M⇖ J" "⋀ f g . f∈G ⟹ g∈G ⟹ ∃d∈I⇀⇗M⇖ J . d⊇f ∧ d⊇g"
  shows "⋃G ∈ Pow(I×J)" "function(⋃G)"
proof -
  from assms
  show "⋃G ∈ Pow(I×J)"
    using Union_Pow_iff
    unfolding PFun_Space_Rel_def
    by auto
next
  show "function(⋃G)"
    unfolding function_def
  proof(auto)
    fix B B' x y y'
    assume "B ∈ G" "⟨x, y⟩ ∈ B" "B' ∈ G" "⟨x, y'⟩ ∈ B'"
    moreover from calculation assms
    obtain d where "d ∈ I ⇀⇗M⇖ J" "function(d)" "⟨x, y⟩ ∈ d"  "⟨x, y'⟩ ∈ d"
      using pfun_is_function
      by force
    ultimately
    show "y=y'"
      unfolding function_def
      by auto
  qed
qed

lemma pfun_Un_filter_closed'':
  assumes "G ⊆I⇀⇗M⇖ J" "⋀ f g . f∈G ⟹ g∈G ⟹ ∃d∈G . d⊇f ∧ d⊇g"
  shows "⋃G ∈ Pow(I×J)" "function(⋃G)"
proof -
  from assms
  have "⋀ f g . f∈G ⟹ g∈G ⟹ ∃d∈I⇀⇗M⇖ J . d⊇f ∧ d⊇g"
    using subsetD[OF assms(1),THEN [2] bexI]
    by force
  then
  show "⋃G ∈ Pow(I×J)"  "function(⋃G)"
    using assms pfun_Un_filter_closed
    unfolding PFun_Space_Rel_def
    by auto
qed

lemma pfun_Un_filter_closed':
  assumes "G ⊆I⇀⇗M⇖ J" "⋀ f g . f∈G ⟹ g∈G ⟹ ∃d∈G . d⊇f ∧ d⊇g" "M(G)"
  shows "⋃G ∈ I⇀⇗M⇖ J"
  using assms pfun_Un_filter_closed''
  unfolding PFun_Space_Rel_def
  by auto

lemma pfunD :
  assumes "f ∈ A⇀⇗M⇖ B"
  shows "∃C[M]. C⊆A ∧ f ∈ C→B"
proof -
  note assms
  moreover from this
  have "f∈Pow(A×B)" "function(f)" "M(f)"
    unfolding PFun_Space_Rel_def
    by simp_all
  moreover from this
  have "domain(f) ⊆ A" "f ∈ domain(f) → B" "M(domain(f))"
    using assms Pow_iff[of f "A×B"] domain_subset Pi_iff
    by auto
  ultimately
  show ?thesis by auto
qed

lemma pfunD_closed :
  assumes "f ∈ A⇀⇗M⇖ B"
  shows "M(f)"
  using assms
  unfolding PFun_Space_Rel_def by simp

lemma pfun_singletonI :
  assumes "x ∈ A" "b ∈ B" "M(A)" "M(B)"
  shows "{⟨x,b⟩} ∈ A⇀⇗M⇖ B"
  using assms transM[of x A] transM[of b B]
  unfolding PFun_Space_Rel_def function_def
  by auto

lemma pfun_unionI :
  assumes "f ∈ A⇀⇗M⇖ B" "g ∈ A⇀⇗M⇖ B" "domain(f)∩domain(g)=0"
  shows "f∪g ∈ A⇀⇗M⇖ B"
  using assms
  unfolding PFun_Space_Rel_def function_def
  by blast

lemma (in M_library) pfun_restrict_eq_imp_compat:
  assumes "f ∈ I⇀⇗M⇖ J" "g ∈ I⇀⇗M⇖ J" "M(J)"
    "restrict(f, domain(f) ∩ domain(g)) = restrict(g, domain(f) ∩ domain(g))"
  shows "f ∪ g ∈ I⇀⇗M⇖ J"
proof -
  note assms
  moreover from this
  obtain C D where "f : C → J" "C ⊆ I" "D ⊆ I" "M(C)" "M(D)" "g : D → J"
    using pfunD[of f] pfunD[of g] by force
  moreover from calculation
  have "f∪g ∈ C∪D → J"
    using restrict_eq_imp_Un_into_Pi'[OF ‹f∈C→_› ‹g∈D→_›]
    by auto
  ultimately
  show ?thesis
    using pfunI[of "C∪D" _ "f∪g"] Un_subset_iff pfunD_closed function_space_rel_char
    by auto
qed

lemma FiniteFun_pfunI :
  assumes "f ∈ A-||> B" "M(A)" "M(B)"
  shows "f ∈ A ⇀⇗M⇖ B"
  using assms(1)
proof(induct)
  case emptyI
  then
  show ?case
    using assms nonempty mem_function_space_rel_abs pfunI[OF empty_subsetI, of 0]
    by simp
next
  case (consI a b h)
  note consI
  moreover from this
  have "M(a)" "M(b)" "M(h)" "domain(h) ⊆ A"
    using transM[OF _ ‹M(A)›] transM[OF _ ‹M(B)›]
      FinD
      FiniteFun_domain_Fin
      pfunD_closed
    by simp_all
  moreover from calculation
  have "{a}∪domain(h)⊆A" "M({a}∪domain(h))" "M(cons(<a,b>,h))" "domain(cons(<a,b>,h)) = {a}∪domain(h)"
    by auto
  moreover from calculation
  have "cons(<a,b>,h) ∈ {a}∪domain(h) → B"
    using FiniteFun_is_fun[OF FiniteFun.consI, of a A b B h]
    by auto
  ultimately
  show "cons(<a,b>,h) ∈ A ⇀⇗M⇖ B"
    using assms  mem_function_space_rel_abs pfunI
    by simp_all
qed

lemma PFun_FiniteFunI :
  assumes "f ∈ A ⇀⇗M⇖ B" "Finite(f)"
  shows  "f ∈ A-||> B"
proof -
  from assms
  have "f∈Fin(A×B)" "function(f)"
    using Finite_Fin Pow_iff
    unfolding PFun_Space_Rel_def
    by auto
  then
  show ?thesis
    using FiniteFunI by simp
qed

end ― ‹locale‹M_cardinals››

(* Fn_rel should be the relativization *)
definition
  Fn_rel :: "[i⇒o,i,i,i] ⇒ i" (‹Fn⇗_⇖'(_,_,_')›) where
  "Fn_rel(M,κ,I,J) ≡ {f ∈ I⇀⇗M⇖ J . f ≺⇗M⇖ κ}"

context  M_library
begin

lemma Fn_rel_subset_PFun_rel : "Fn⇗M⇖(κ,I,J) ⊆ I⇀⇗M⇖ J"
  unfolding Fn_rel_def by auto

lemma Fn_relI[intro]:
  assumes "f : d → J" "d ⊆ I" "f ≺⇗M⇖ κ" "M(d)" "M(J)" "M(f)"
  shows "f ∈ Fn_rel(M,κ,I,J)"
  using assms pfunI mem_function_space_rel_abs
  unfolding Fn_rel_def
  by auto

lemma Fn_relD[dest]:
  assumes "p ∈ Fn_rel(M,κ,I,J)"
  shows "∃C[M]. C⊆I ∧ p : C → J ∧ p ≺⇗M⇖ κ"
  using assms pfunD
  unfolding Fn_rel_def
  by simp

lemma Fn_rel_is_function:
  assumes "p ∈ Fn_rel(M,κ,I,J)"
  shows "function(p)" "M(p)" "p ≺⇗M⇖ κ" "p∈ I⇀⇗M⇖ J"
  using assms
  unfolding Fn_rel_def PFun_Space_Rel_def by simp_all

lemma Fn_rel_mono:
  assumes "p ∈ Fn_rel(M,κ,I,J)" "κ ≺⇗M⇖ κ'" "M(κ)" "M(κ')"
  shows "p ∈ Fn_rel(M,κ',I,J)"
  using assms lesspoll_rel_trans[OF _ assms(2)] cardinal_rel_closed
    Fn_rel_is_function(2)[OF assms(1)]
  unfolding Fn_rel_def
  by simp

lemma Fn_rel_mono':
  assumes "p ∈ Fn_rel(M,κ,I,J)" "κ ≲⇗M⇖ κ'" "M(κ)" "M(κ')"
  shows "p ∈ Fn_rel(M,κ',I,J)"
proof -
  note assms
  then
  consider "κ ≺⇗M⇖ κ'"  | "κ ≈⇗M⇖ κ'"
    using lepoll_rel_iff_leqpoll_rel
    by auto
  then
  show ?thesis
  proof(cases)
    case 1
    with assms show ?thesis using Fn_rel_mono by simp
  next
    case 2
    then show ?thesis
      using assms cardinal_rel_closed Fn_rel_is_function[OF assms(1)]
        lesspoll_rel_eq_trans
      unfolding Fn_rel_def
      by simp
  qed
qed

lemma Fn_csucc:
  assumes "Ord(κ)" "M(κ)"
  shows "Fn_rel(M,(κ+)⇗M⇖,I,J) = {p∈ I⇀⇗M⇖ J . p  ≲⇗M⇖ κ}"   (is "?L=?R")
  using assms
proof(intro equalityI)
  show "?L ⊆ ?R"
  proof(intro subsetI)
    fix p
    assume "p∈?L"
    then
    have "p ≺⇗M⇖ csucc_rel(M,κ)" "M(p)" "p∈ I⇀⇗M⇖ J"
      using Fn_rel_is_function by simp_all
    then
    show "p∈?R"
      using  assms lesspoll_rel_csucc_rel by simp
  qed
next
  show "?R⊆?L"
  proof(intro subsetI)
    fix p
    assume "p∈?R"
    then
    have  "p∈ I⇀⇗M⇖ J" "p ≲⇗M⇖ κ"
      using assms lesspoll_rel_csucc_rel by simp_all
    then
    show "p∈?L"
      using  assms lesspoll_rel_csucc_rel pfunD_closed
      unfolding Fn_rel_def
      by simp
  qed
qed

lemma Finite_imp_lesspoll_nat:
  assumes "Finite(A)"
  shows "A ≺ nat"
  using assms subset_imp_lepoll[OF naturals_subset_nat] eq_lepoll_trans
    n_lesspoll_nat eq_lesspoll_trans
  unfolding Finite_def lesspoll_def by auto

lemma FinD_Finite :
  assumes "a∈Fin(A)"
  shows "Finite(a)"
  using assms
  by(induct,simp_all)

lemma Fn_rel_nat_eq_FiniteFun:
  assumes "M(I)" "M(J)"
  shows "I -||> J = Fn_rel(M,ω,I,J)"
proof(intro equalityI subsetI)
  fix p
  assume "p∈I -||> J"
  with assms
  have "p∈ I ⇀⇗M⇖ J" "Finite(p)"
    using FiniteFun_pfunI FinD_Finite[OF subsetD[OF FiniteFun.dom_subset,OF ‹p∈_›]]
    by auto
  moreover from this
  have "p ≺⇗M⇖ ω"
    using Finite_lesspoll_rel_nat pfunD_closed[of p] n_lesspoll_rel_nat
    by simp
  ultimately
  show "p∈ Fn_rel(M,ω,I,J)"
    unfolding Fn_rel_def by simp
next
  fix p
  assume "p∈ Fn_rel(M,ω,I,J)"
  then
  have "p∈ I ⇀⇗M⇖ J"  "p ≺⇗M⇖ ω"
    unfolding Fn_rel_def by simp_all
  moreover from this
  have "Finite(p)"
    using Finite_cardinal_rel_Finite lesspoll_rel_nat_is_Finite_rel pfunD_closed
      cardinal_rel_closed[of p]  Finite_cardinal_rel_iff'[THEN iffD1]
    by simp
  ultimately
  show "p∈I -||> J"
    using PFun_FiniteFunI
    by simp
qed

lemma Fn_nat_abs:
  assumes "M(I)" "M(J)"
  shows "Fn(nat,I,J) = Fn_rel(M,ω,I,J)"
  using assms Fn_rel_nat_eq_FiniteFun Fn_nat_eq_FiniteFun
  by simp

lemma Fn_rel_singletonI:
  assumes "x ∈ I" "j ∈ J" "1 ≺⇗M⇖ κ" "M(κ)" "M(I)" "M(J)"
  shows "{⟨x,j⟩} ∈ Fn⇗M⇖(κ,I,J)"
  using pfun_singletonI transM[of x] transM[of j] assms
    eq_lesspoll_rel_trans[OF singleton_eqpoll_rel_1]
  unfolding Fn_rel_def
  by auto

end ― ‹locale‹M_library››

definition
  Fnle_rel :: "[i⇒o,i,i,i] ⇒ i" (‹Fnle⇗_⇖'(_,_,_')›) where
  "Fnle_rel(M,κ,I,J) ≡ Fnlerel(Fn⇗M⇖(κ,I,J))"

abbreviation
  Fn_r_set ::  "[i,i,i,i] ⇒ i" (‹Fn⇗_⇖'(_,_,_')›) where
  "Fn_r_set(M) ≡ Fn_rel(##M)"

abbreviation
  Fnle_r_set ::  "[i,i,i,i] ⇒ i" (‹Fnle⇗_⇖'(_,_,_')›) where
  "Fnle_r_set(M) ≡ Fnle_rel(##M)"


context M_library
begin

lemma Fnle_relI[intro]:
  assumes "p ∈ Fn_rel(M,κ,I,J)" "q ∈ Fn_rel(M,κ,I,J)" "p ⊇ q"
  shows "<p,q> ∈ Fnle_rel(M,κ,I,J)"
  using assms unfolding Fnlerel_def Fnle_rel_def FnleR_def Rrel_def
  by auto

lemma Fnle_relD[dest]:
  assumes "<p,q> ∈ Fnle_rel(M,κ,I,J)"
  shows "p ∈ Fn_rel(M,κ,I,J)" "q ∈ Fn_rel(M,κ,I,J)" "p ⊇ q"
  using assms unfolding Fnlerel_def Fnle_rel_def FnleR_def Rrel_def
  by auto

lemma Fn_rel_closed[intro,simp]:
  assumes "M(κ)" "M(I)" "M(J)"
  shows "M(Fn⇗M⇖(κ,I,J))"
  using assms separation_cardinal_rel_lesspoll_rel PFun_Space_closed
  unfolding Fn_rel_def
  by auto

lemma Fn_rel_subset_Pow:
  assumes "M(κ)" "M(I)" "M(J)"
  shows "Fn⇗M⇖(κ,I,J) ⊆ Pow(I×J)"
  unfolding Fn_rel_def PFun_Space_Rel_def
  by auto

lemma Fnle_rel_closed[intro,simp]:
  assumes "M(κ)" "M(I)" "M(J)"
  shows "M(Fnle⇗M⇖(κ,I,J))"
  unfolding Fnle_rel_def Fnlerel_def Rrel_def FnleR_def
  using assms supset_separation Fn_rel_closed
  by auto

lemma zero_in_Fn_rel:
  assumes "0<κ" "M(κ)" "M(I)" "M(J)"
  shows "0 ∈ Fn⇗M⇖(κ, I, J)"
  unfolding Fn_rel_def
  using zero_in_PFun_rel zero_lesspoll_rel assms
  by simp

lemma zero_top_Fn_rel:
  assumes "p∈Fn⇗M⇖(κ, I, J)" "0<κ" "M(κ)" "M(I)" "M(J)"
  shows "⟨p, 0⟩ ∈ Fnle⇗M⇖(κ, I, J)"
  using assms zero_in_Fn_rel unfolding preorder_on_def refl_def trans_on_def
  by auto

lemma preorder_on_Fnle_rel:
  assumes "M(κ)" "M(I)" "M(J)"
  shows "preorder_on(Fn⇗M⇖(κ, I, J), Fnle⇗M⇖(κ, I, J))"
  unfolding preorder_on_def refl_def trans_on_def
  by blast

end ― ‹locale‹M_library››

end